diff --git a/apps/ios/Shared/Model/AppAPITypes.swift b/apps/ios/Shared/Model/AppAPITypes.swift index 40b88ec338..fffff5e05d 100644 --- a/apps/ios/Shared/Model/AppAPITypes.swift +++ b/apps/ios/Shared/Model/AppAPITypes.swift @@ -133,6 +133,7 @@ enum ChatCommand: ChatCmdProtocol { case apiSetConnectionIncognito(connId: Int64, incognito: Bool) case apiChangeConnectionUser(connId: Int64, userId: Int64) case apiConnectPlan(userId: Int64, connLink: String, resolveMode: PlanResolveMode, linkOwnerSig: LinkOwnerSig?) + case apiSendServiceRequest(userId: Int64, target: String, timeoutSec: Double?, requestJSON: String) case apiPrepareContact(userId: Int64, connLink: CreatedConnLink, contactShortLinkData: ContactShortLinkData, verifiedDomain: SimplexDomain?) case apiPrepareGroup(userId: Int64, connLink: CreatedConnLink, directLink: Bool, groupShortLinkData: GroupShortLinkData, verifiedDomain: SimplexDomain?) case apiChangePreparedContactUser(contactId: Int64, newUserId: Int64) @@ -355,6 +356,9 @@ enum ChatCommand: ChatCmdProtocol { let resolveStr = resolveMode == .unknown ? "" : " resolve=\(resolveMode.rawValue)" let sigStr = if let linkOwnerSig { " sig=\(encodeJSON(linkOwnerSig))" } else { "" } return "/_connect plan \(userId) \(connLink)\(resolveStr)\(sigStr)" + case let .apiSendServiceRequest(userId, target, timeoutSec, requestJSON): + let timeoutStr = if let timeoutSec { " timeout=\(timeoutSec)" } else { "" } + return "/_service_request \(userId) \(target)\(timeoutStr) \(requestJSON)" case let .apiPrepareContact(userId, connLink, contactShortLinkData, verifiedDomain): return "/_prepare contact \(userId) \(connLink.cmdString)\(verifiedDomain.map{ " \($0.cmdString)" } ?? "") \(encodeJSON(contactShortLinkData))" case let .apiPrepareGroup(userId, connLink, directLink, groupShortLinkData, verifiedDomain): return "/_prepare group \(userId) \(connLink.cmdString) direct=\(onOff(directLink))\(verifiedDomain.map{ " \($0.cmdString)" } ?? "") \(encodeJSON(groupShortLinkData))" case let .apiChangePreparedContactUser(contactId, newUserId): return "/_set contact user @\(contactId) \(newUserId)" @@ -543,6 +547,7 @@ enum ChatCommand: ChatCmdProtocol { case .apiSetConnectionIncognito: return "apiSetConnectionIncognito" case .apiChangeConnectionUser: return "apiChangeConnectionUser" case .apiConnectPlan: return "apiConnectPlan" + case .apiSendServiceRequest: return "apiSendServiceRequest" case .apiPrepareContact: return "apiPrepareContact" case .apiPrepareGroup: return "apiPrepareGroup" case .apiChangePreparedContactUser: return "apiChangePreparedContactUser" @@ -821,6 +826,7 @@ enum ChatResponse1: Decodable, ChatAPIResult { case connectionIncognitoUpdated(user: UserRef, toConnection: PendingContactConnection) case connectionUserChanged(user: UserRef, fromConnection: PendingContactConnection, toConnection: PendingContactConnection, newUser: UserRef) case connectionPlan(user: UserRef, connLink: CreatedConnLink, planSimplexName: SimplexNameInfo?, otherSimplexName: SimplexNameInfo?, connectionPlan: ConnectionPlan) + case serviceResponse(user: UserRef, responseData: JSONValue) case newPreparedChat(user: UserRef, chat: ChatData) case contactUserChanged(user: UserRef, fromContact: Contact, newUser: UserRef, toContact: Contact) case groupUserChanged(user: UserRef, fromGroup: GroupInfo, newUser: UserRef, toGroup: GroupInfo) @@ -865,6 +871,7 @@ enum ChatResponse1: Decodable, ChatAPIResult { case .connectionIncognitoUpdated: "connectionIncognitoUpdated" case .connectionUserChanged: "connectionUserChanged" case .connectionPlan: "connectionPlan" + case .serviceResponse: "serviceResponse" case .newPreparedChat: "newPreparedChat" case .contactUserChanged: "contactUserChanged" case .groupUserChanged: "groupUserChanged" diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift index e3a6ae30b9..91b098c482 100644 --- a/apps/ios/Shared/Model/ChatModel.swift +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -298,30 +298,47 @@ class ChatItemDummyModel: ObservableObject { func sendUpdate() { objectWillChange.send() } } +// A directory search and a connection can overlap - tapping a result starts a connection while +// the search is still running - so the single progress slot records its owner. +enum ConnectProgressOwner { + case connect + case directorySearch +} + class ConnectProgressManager: ObservableObject { @Published private var connectInProgress: String? = nil @Published private var connectProgressByTimeout: Bool = false private var onCancel: (() -> Void)? + private var owner: ConnectProgressOwner? static let shared = ConnectProgressManager() - func startConnectProgress(_ text: String, onCancel: (() -> Void)? = nil) { + func startConnectProgress(_ text: String, owner: ConnectProgressOwner = .connect, onCancel: (() -> Void)? = nil) { connectInProgress = text + self.owner = owner self.onCancel = onCancel DispatchQueue.main.asyncAfter(deadline: .now() + 1) { self.connectProgressByTimeout = self.connectInProgress != nil } } - func stopConnectProgress() { + // a late directory search result must not clear the spinner that now belongs to a connection + func stopConnectProgress(_ owner: ConnectProgressOwner = .connect) { + if let current = self.owner, current != owner { return } connectInProgress = nil + self.owner = nil onCancel = nil connectProgressByTimeout = false } + // a user-initiated cancel, and the takeover in planAndConnect, cancel whatever is running func cancelConnectProgress() { - onCancel?() - stopConnectProgress() + let cancel = onCancel + owner = nil + onCancel = nil + connectInProgress = nil + connectProgressByTimeout = false + cancel?() } var showConnectProgress: String? { diff --git a/apps/ios/Shared/Model/DirectorySearch.swift b/apps/ios/Shared/Model/DirectorySearch.swift new file mode 100644 index 0000000000..b20bab7de2 --- /dev/null +++ b/apps/ios/Shared/Model/DirectorySearch.swift @@ -0,0 +1,73 @@ +// +// DirectorySearch.swift +// SimpleX +// +// Created by spaced4ndy on 12.08.2026. +// Copyright © 2026 SimpleX Chat. All rights reserved. +// + +import Foundation +import SimpleXChat + +// The directory's contact address, as published in docs/DIRECTORY.md. It must be the short +// link: only that form carries the address DR keys that service requests require, so the full +// links on the What's New cards cannot be substituted here. +let DIRECTORY_SERVICE_LINK = "https://smp4.simplex.im/a#lXUjJW5vHYQzoLYgmi8GbxkGP41_kjefFvBrdwg-0Ok" + +// A service request is a full DR handshake, so it is slower than a local API call; the user +// gets a cancellable spinner while it runs and a retry row if it times out. +let DIRECTORY_SEARCH_TIMEOUT_SEC: Double = 10 + +struct DirectoryPublicLink: Decodable, Hashable { + var connFullLink: String? = nil + var connShortLink: String? = nil +} + +struct DirectoryEntryType: Decodable, Hashable { + var groupType: GroupType? = nil + var summary: GroupSummary +} + +struct DirectorySearchEntry: Decodable, Hashable, Identifiable { + var entryType: DirectoryEntryType + var displayName: String + var simplexName: String? = nil + var groupLink: DirectoryPublicLink + var shortDescr: String? = nil + var image: String? = nil + var activeAt: Date? = nil + var createdAt: Date? = nil + + // the directory drops entries with no link, but the response is untrusted input + var connectLink: String? { groupLink.connShortLink ?? groupLink.connFullLink } + + // the link is stable and unique per entry, so it also de-duplicates across pages + var id: String { connectLink ?? displayName } +} + +private struct DirectorySearchResponse: Decodable { + var type: String + var entries: [DirectorySearchEntry]? + var searchCursor: JSONValue? +} + +struct DirectorySearchResults { + var entries: [DirectorySearchEntry] + // opaque: stored and echoed back on the next request, never inspected + var cursor: JSONValue? +} + +func directorySearchRequestJSON(_ text: String, _ cursor: JSONValue?) -> String { + var req: [String: JSONValue] = ["type": .string("search"), "searchText": .string(text)] + if let cursor { req["searchCursor"] = cursor } + return encodeJSON(JSONValue.object(req)) +} + +// The response is a tagged object: searchResults or error. Anything else is a failure rather +// than something to parse leniently - it comes from outside the app. +func parseDirectorySearchResponse(_ resp: JSONValue) -> DirectorySearchResults? { + guard let r: DirectorySearchResponse = decodeJSONValue(resp), r.type == "searchResults" else { + return nil + } + return DirectorySearchResults(entries: r.entries ?? [], cursor: r.searchCursor) +} diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index 7a934fc746..6b40b909d6 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -1032,6 +1032,23 @@ func apiChangeConnectionUser(connId: Int64, userId: Int64) async throws -> Pendi if let r { throw r.unexpected } else { return nil } } +// Blocks until the directory replies or the timeout elapses. +func apiSearchDirectory(_ text: String, cursor: JSONValue?) async -> DirectorySearchResults? { + guard let userId = ChatModel.shared.currentUser?.userId else { + logger.error("apiSearchDirectory: no current user") + return nil + } + let req = directorySearchRequestJSON(text, cursor) + let r: APIResult = await chatApiSendCmd( + .apiSendServiceRequest(userId: userId, target: DIRECTORY_SERVICE_LINK, timeoutSec: DIRECTORY_SEARCH_TIMEOUT_SEC, requestJSON: req) + ) + if case let .result(.serviceResponse(_, responseData)) = r { + return parseDirectorySearchResponse(responseData) + } + logger.error("apiSearchDirectory error: \(String(describing: r))") + return nil +} + func apiConnectPlan(connLink: String, resolveMode: PlanResolveMode = .unknown, linkOwnerSig: LinkOwnerSig? = nil, inProgress: BoxedValue) async -> ConnectionPlanResult? { guard let userId = ChatModel.shared.currentUser?.userId else { logger.error("apiConnectPlan: no current user") diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index 33d683288a..6219b68e55 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -716,6 +716,50 @@ private func encodeCJSON(_ value: T) -> [CChar] { encodeJSON(value).cString(using: .utf8)! } +// Type-erased JSON, so a service response can cross the API layer without it knowing which +// service produced the payload. Callers re-decode it into their own type with decodeJSONValue. +public enum JSONValue: Codable, Hashable { + case null + case bool(Bool) + case number(Double) + case string(String) + case array([JSONValue]) + case object([String: JSONValue]) + + public init(from decoder: Decoder) throws { + let c = try decoder.singleValueContainer() + if c.decodeNil() { self = .null } + else if let v = try? c.decode(Bool.self) { self = .bool(v) } + else if let v = try? c.decode(Double.self) { self = .number(v) } + else if let v = try? c.decode(String.self) { self = .string(v) } + else if let v = try? c.decode([JSONValue].self) { self = .array(v) } + else if let v = try? c.decode([String: JSONValue].self) { self = .object(v) } + else { + throw DecodingError.dataCorruptedError(in: c, debugDescription: "invalid JSON value") + } + } + + public func encode(to encoder: Encoder) throws { + var c = encoder.singleValueContainer() + switch self { + case .null: try c.encodeNil() + case let .bool(v): try c.encode(v) + case let .number(v): try c.encode(v) + case let .string(v): try c.encode(v) + case let .array(v): try c.encode(v) + case let .object(v): try c.encode(v) + } + } + + public var stringValue: String? { + if case let .string(v) = self { return v } else { return nil } + } +} + +public func decodeJSONValue(_ value: JSONValue) -> T? { + decodeJSON(encodeJSON(value)) +} + // Spec: spec/api.md#ChatError public enum ChatError: Decodable, Hashable, Error { case error(errorType: ChatErrorType) diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt index 340ba2c1ad..bc4816de2f 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt @@ -45,15 +45,22 @@ import kotlin.collections.ArrayList import kotlin.random.Random import kotlin.time.* +// A directory search and a connection can overlap - tapping a result starts a connection while +// the search is still running - so the single progress slot records its owner: a late search +// result must not clear the spinner that now belongs to the connection. +enum class ConnectProgressOwner { Connect, DirectorySearch } + object ConnectProgressManager { private val connectInProgress = mutableStateOf(null) private val connectProgressByTimeout = mutableStateOf(false) private var onCancel: (() -> Unit)? = null + private var owner: ConnectProgressOwner? = null private val coroutineScope = CoroutineScope(SupervisorJob() + Dispatchers.Main) - fun startConnectProgress(text: String, onCancel: (() -> Unit)? = null) { + fun startConnectProgress(text: String, owner: ConnectProgressOwner = ConnectProgressOwner.Connect, onCancel: (() -> Unit)? = null) { connectInProgress.value = text + this.owner = owner this.onCancel = onCancel coroutineScope.launch { delay(1000) @@ -61,15 +68,22 @@ object ConnectProgressManager { } } - fun stopConnectProgress() { + fun stopConnectProgress(owner: ConnectProgressOwner = ConnectProgressOwner.Connect) { + if (this.owner != null && this.owner != owner) return connectInProgress.value = null + this.owner = null onCancel = null connectProgressByTimeout.value = false } + // a user-initiated cancel, and the takeover in planAndConnect, cancel whatever is running fun cancelConnectProgress() { - onCancel?.invoke() - stopConnectProgress() + val cancel = onCancel + owner = null + onCancel = null + connectInProgress.value = null + connectProgressByTimeout.value = false + cancel?.invoke() } val showConnectProgress: String? get() = diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/DirectorySearch.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/DirectorySearch.kt new file mode 100644 index 0000000000..198a7c60bf --- /dev/null +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/DirectorySearch.kt @@ -0,0 +1,66 @@ +package chat.simplex.common.model + +import kotlinx.datetime.Instant +import kotlinx.serialization.Serializable +import kotlinx.serialization.json.* + +// The directory's contact address, as published in docs/DIRECTORY.md. It must be the short +// link: only that form carries the address DR keys that service requests require, so the full +// links on the What's New cards cannot be substituted here. +const val DIRECTORY_SERVICE_LINK = "https://smp4.simplex.im/a#lXUjJW5vHYQzoLYgmi8GbxkGP41_kjefFvBrdwg-0Ok" + +// A service request is a full DR handshake, so it is slower than a local API call; the user +// gets a cancellable spinner while it runs and a retry row if it times out. +const val DIRECTORY_SEARCH_TIMEOUT_SEC = 10.0 + +@Serializable +data class DirectoryPublicLink( + val connFullLink: String? = null, + val connShortLink: String? = null, +) + +@Serializable +data class DirectoryEntryType( + val groupType: GroupType? = null, + val summary: GroupSummary, +) + +@Serializable +data class DirectorySearchEntry( + val entryType: DirectoryEntryType, + val displayName: String, + val simplexName: String? = null, + val groupLink: DirectoryPublicLink, + val shortDescr: String? = null, + val image: String? = null, + val activeAt: Instant? = null, + val createdAt: Instant? = null, +) { + // the directory drops entries with no link, but the response is untrusted input + val connectLink: String? get() = groupLink.connShortLink ?: groupLink.connFullLink +} + +data class DirectorySearchResults( + val entries: List, + // opaque: stored and echoed back on the next request, never inspected + val cursor: JsonObject?, +) + +fun directorySearchRequest(text: String, cursor: JsonObject?): JsonObject = buildJsonObject { + put("type", JsonPrimitive("search")) + put("searchText", JsonPrimitive(text)) + if (cursor != null) put("searchCursor", cursor) +} + +// The response is a tagged object: searchResults or error. Anything else is treated as a failure +// rather than parsed leniently - it comes from outside the app. +fun parseDirectorySearchResponse(resp: JsonObject): DirectorySearchResults? = + when ((resp["type"] as? JsonPrimitive)?.contentOrNull) { + "searchResults" -> { + val entries = (resp["entries"] as? JsonArray)?.mapNotNull { + runCatching { json.decodeFromJsonElement(it) }.getOrNull() + } ?: emptyList() + DirectorySearchResults(entries, resp["searchCursor"] as? JsonObject) + } + else -> null + } diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt index 037c02b1c2..16c5db62b9 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt @@ -1531,6 +1531,17 @@ object ChatController { return null } + // Blocks until the directory replies or the timeout elapses, so callers must use + // withLongRunningApi, not the single-threaded withBGApi. + suspend fun apiSearchDirectory(rh: Long?, text: String, cursor: JsonObject?): DirectorySearchResults? { + val userId = kotlin.runCatching { currentUserId("apiSearchDirectory") }.getOrElse { return null } + val req = directorySearchRequest(text, cursor) + val r = sendCmdWithRetry(rh, CC.APISendServiceRequest(userId, DIRECTORY_SERVICE_LINK, DIRECTORY_SEARCH_TIMEOUT_SEC, req)) + if (r is API.Result && r.res is CR.CRServiceResponse) return parseDirectorySearchResponse(r.res.responseData) + Log.e(TAG, "apiSearchDirectory error: $r") + return null + } + suspend fun apiConnectPlan(rh: Long?, connLink: String, resolveMode: PlanResolveMode = PlanResolveMode.PRMUnknown, linkOwnerSig: LinkOwnerSig? = null, inProgress: MutableState): ConnectionPlanResult? { val userId = kotlin.runCatching { currentUserId("apiConnectPlan") }.getOrElse { return null } val r = sendCmdWithRetry(rh, CC.APIConnectPlan(userId, connLink, resolveMode, linkOwnerSig), inProgress = inProgress) @@ -3879,6 +3890,7 @@ sealed class CC { class ApiSetConnectionIncognito(val connId: Long, val incognito: Boolean): CC() class ApiChangeConnectionUser(val connId: Long, val userId: Long): CC() class APIConnectPlan(val userId: Long, val connLink: String, val resolveMode: PlanResolveMode = PlanResolveMode.PRMUnknown, val linkOwnerSig: LinkOwnerSig? = null): CC() + class APISendServiceRequest(val userId: Long, val target: String, val timeoutSec: Double?, val request: JsonObject): CC() class APIPrepareContact(val userId: Long, val connLink: CreatedConnLink, val contactShortLinkData: ContactShortLinkData, val verifiedDomain: SimplexDomain? = null): CC() class APIPrepareGroup(val userId: Long, val connLink: CreatedConnLink, val directLink: Boolean, val groupShortLinkData: GroupShortLinkData, val verifiedDomain: SimplexDomain? = null): CC() class APIChangePreparedContactUser(val contactId: Long, val newUserId: Long): CC() @@ -4092,6 +4104,10 @@ sealed class CC { val sigStr = if (linkOwnerSig != null) " sig=${json.encodeToString(linkOwnerSig)}" else "" "/_connect plan $userId $connLink$resolveStr$sigStr" } + is APISendServiceRequest -> { + val timeoutStr = if (timeoutSec != null) " timeout=$timeoutSec" else "" + "/_service_request $userId $target$timeoutStr ${json.encodeToString(request)}" + } is APIPrepareContact -> "/_prepare contact $userId ${connLink.cmdString}${verifiedDomain?.let { " ${it.cmdString}" } ?: ""} ${json.encodeToString(contactShortLinkData)}" is APIPrepareGroup -> "/_prepare group $userId ${connLink.cmdString} direct=${onOff(directLink)}${verifiedDomain?.let { " ${it.cmdString}" } ?: ""} ${json.encodeToString(groupShortLinkData)}" is APIChangePreparedContactUser -> "/_set contact user @$contactId $newUserId" @@ -4278,6 +4294,7 @@ sealed class CC { is ApiSetConnectionIncognito -> "apiSetConnectionIncognito" is ApiChangeConnectionUser -> "apiChangeConnectionUser" is APIConnectPlan -> "apiConnectPlan" + is APISendServiceRequest -> "apiSendServiceRequest" is APIPrepareContact -> "apiPrepareContact" is APIPrepareGroup -> "apiPrepareGroup" is APIChangePreparedContactUser -> "apiChangePreparedContactUser" @@ -6564,6 +6581,7 @@ sealed class CR { @Serializable @SerialName("connectionIncognitoUpdated") class ConnectionIncognitoUpdated(val user: UserRef, val toConnection: PendingContactConnection): CR() @Serializable @SerialName("connectionUserChanged") class ConnectionUserChanged(val user: UserRef, val fromConnection: PendingContactConnection, val toConnection: PendingContactConnection, val newUser: UserRef): CR() @Serializable @SerialName("connectionPlan") class CRConnectionPlan(val user: UserRef, val connLink: CreatedConnLink, val planSimplexName: SimplexNameInfo? = null, val otherSimplexName: SimplexNameInfo? = null, val connectionPlan: ConnectionPlan): CR() + @Serializable @SerialName("serviceResponse") class CRServiceResponse(val user: UserRef, val responseData: JsonObject): CR() @Serializable @SerialName("newPreparedChat") class NewPreparedChat(val user: UserRef, val chat: Chat): CR() @Serializable @SerialName("contactUserChanged") class ContactUserChanged(val user: UserRef, val fromContact: Contact, val newUser: UserRef, val toContact: Contact): CR() @Serializable @SerialName("groupUserChanged") class GroupUserChanged(val user: UserRef, val fromGroup: GroupInfo, val newUser: UserRef, val toGroup: GroupInfo): CR() diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 3bff611a28..73f4505c87 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -25,6 +25,7 @@ import Control.Applicative (optional, (<|>)) import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A import Data.Char (isSpace) +import qualified Data.Aeson as J import Data.Either (fromRight) import Data.Functor (($>)) import Data.Maybe (fromMaybe, isNothing) @@ -66,6 +67,7 @@ data DirectoryEvent | DEItemEditIgnored Contact | DEItemDeleteIgnored Contact | DEContactCommand Contact ChatItemId ADirectoryCmd + | DEServiceRequest AgentInvId J.Object | DELogChatResponse Text deriving (Show) @@ -110,6 +112,7 @@ crDirectoryEvent_ = \case where ciId = chatItemId' ci err = ADC SDRUser DCUnknownCommand + CEvtServiceRequest {requestId, requestData} -> Just $ DEServiceRequest requestId requestData CEvtMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage CEvtChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors) _ -> Nothing diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs index d2df341545..c84f2a488b 100644 --- a/apps/simplex-directory-service/src/Directory/Listing.hs +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -123,13 +123,8 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma } imgData = imgFileData groupLink =<< image in (de, imgData) - in case publicGroup of - Just PublicGroupProfile {groupLink = sLnk} -> - Just $ entry $ PublicLink Nothing (Just sLnk) - Nothing -> - entry . toPublicLink . connLinkContact <$> gLink_ + in entry <$> groupPublicLink g gLink_ where - toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink imgFileData :: PublicLink -> ImageData -> Maybe (FilePath, ByteString) imgFileData PublicLink {connFullLink, connShortLink} (ImageData img) = let (img', imgExt) = @@ -145,6 +140,14 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma Right img'' -> Just (imgFile, img'') Left _ -> Nothing +-- a public group publishes its own link in the profile; other groups only have the link the service created +groupPublicLink :: GroupInfo -> Maybe GroupLink -> Maybe PublicLink +groupPublicLink GroupInfo {groupProfile = GroupProfile {publicGroup}} gLink_ = case publicGroup of + Just PublicGroupProfile {groupLink = sLnk} -> Just $ PublicLink Nothing (Just sLnk) + Nothing -> toPublicLink . connLinkContact <$> gLink_ + where + toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink + generateListing :: FilePath -> [(GroupInfo, GroupReg, Maybe GroupLink)] -> IO () generateListing dir gs = do createDirectoryIfMissing True dir diff --git a/apps/simplex-directory-service/src/Directory/Rpc.hs b/apps/simplex-directory-service/src/Directory/Rpc.hs new file mode 100644 index 0000000000..fc2d061c14 --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Rpc.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Directory.Rpc where + +import qualified Data.Aeson.TH as JQ +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Directory.Listing +import Directory.Search +import Directory.Store +import Simplex.Chat.Types +import Simplex.Messaging.SimplexName (SimplexNameInfo (..), SimplexNameType (..), shortNameInfoStr) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) + +data DirectoryRequest = DRSearch + { searchText :: Text, + -- opaque to the client: it is stored and echoed back, never inspected + searchCursor :: Maybe SearchCursor + } + +data DirectorySearchEntry = DirectorySearchEntry + { entryType :: DirectoryEntryType, + displayName :: Text, + simplexName :: Maybe Text, + groupLink :: PublicLink, + -- stored text, not DirectoryEntry's MarkdownList: the apps parse markdown locally + shortDescr :: Maybe Text, + image :: Maybe ImageData, + activeAt :: Maybe UTCTime, + createdAt :: Maybe UTCTime + } + +data DirectoryResponse + = DRSearchResults + { entries :: [DirectorySearchEntry], + searchCursor :: Maybe SearchCursor -- Nothing when there are no more results + } + | DRError {errorMessage :: Text} + +$(JQ.deriveJSON defaultJSON ''DirectorySearchEntry) + +$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DR") ''DirectoryRequest) + +$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DR") ''DirectoryResponse) + +-- Entries without any link are dropped: there would be nothing to connect to. +searchEntry :: UTCTime -> GroupInfo -> Maybe GroupLink -> Maybe DirectorySearchEntry +searchEntry now g@GroupInfo {groupProfile, chatTs, createdAt = groupCreatedAt, groupSummary} gLink_ = + entry <$> groupPublicLink g gLink_ + where + GroupProfile {displayName, shortDescr, image, memberAdmission, publicGroup} = groupProfile + entry groupLink = + DirectorySearchEntry + { entryType = DETGroup ((\PublicGroupProfile {groupType} -> groupType) <$> publicGroup) memberAdmission groupSummary, + displayName, + simplexName = shortNameInfoStr . SimplexNameInfo NTPublicGroup <$> verifiedGroupDomain g, + groupLink, + shortDescr, + image, + activeAt = recentRoundedTime 900 now $ fromMaybe groupCreatedAt chatTs, + createdAt = recentRoundedTime 86400 now groupCreatedAt + } diff --git a/apps/simplex-directory-service/src/Directory/Search.hs b/apps/simplex-directory-service/src/Directory/Search.hs index 99e449d0ff..aee368dc74 100644 --- a/apps/simplex-directory-service/src/Directory/Search.hs +++ b/apps/simplex-directory-service/src/Directory/Search.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + module Directory.Search where +import qualified Data.Aeson.TH as JQ import Data.Int (Int64) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Types +import Simplex.Messaging.Parsers (defaultJSON) data SearchRequest = SearchRequest { searchType :: SearchType, @@ -20,3 +24,5 @@ data SearchCursor = SearchCursor } data SearchType = STAll | STRecent | STSearch Text + +$(JQ.deriveJSON defaultJSON ''SearchCursor) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 6b850e71c5..d59dcda521 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -20,17 +20,22 @@ where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, finally, try) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.Attoparsec.Text as A +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) -import Data.Either (fromRight) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Either (fromRight, isRight) +import Data.Foldable (foldl') import Data.List (find, intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M +import Data.Functor (($>)) import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList) import qualified Data.Set as S import Data.Text (Text) @@ -43,6 +48,7 @@ import Directory.Captcha import Directory.Events import Directory.Listing import Directory.Options +import Directory.Rpc import Directory.Search import Directory.Store import Directory.Store.Migrate @@ -54,7 +60,7 @@ import Simplex.Chat.Core import Simplex.Chat.Markdown (Format (..), FormattedText (..), SimplexLinkType (..), parseMaybeMarkdownList, viewName) import Simplex.Chat.Messages import Simplex.Chat.Options -import Simplex.Chat.Protocol (GroupShortLinkData (..), LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion) +import Simplex.Chat.Protocol (GroupShortLinkData (..), compressServiceBody, LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion) import Simplex.Chat.Store.Direct (getContact) import Simplex.Chat.Store.Groups (getGroupLink, getGroupMember, getGroupMemberByMemberId, setGroupCustomData) -- TODO remove setGroupCustomData import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) @@ -103,7 +109,9 @@ data ServiceState = ServiceState pendingCaptchas :: TMap GroupMemberId PendingCaptcha, serviceCC :: TMVar ChatController, eventQ :: TQueue DirectoryEvent, - updateListingsJob :: TMVar () + updateListingsJob :: TMVar (), + -- service requests carry no caller identity, so the only possible bound is global + serviceRequestsInFlight :: TVar Int } data CaptchaMode = CMText | CMAudio @@ -132,7 +140,14 @@ newServiceState opts = do serviceCC <- newEmptyTMVarIO eventQ <- newTQueueIO updateListingsJob <- newEmptyTMVarIO - pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, serviceCC, eventQ, updateListingsJob} + serviceRequestsInFlight <- newTVarIO 0 + pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, serviceCC, eventQ, updateListingsJob, serviceRequestsInFlight} + +-- Requests are answered off the event loop, which is shared with registrations and captchas, +-- so the bound has to be here rather than in the loop. Over the bound requests are refused +-- immediately: a caller gets an error rather than waiting out its timeout. +maxServiceRequestsInFlight :: Int +maxServiceRequestsInFlight = 8 welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do @@ -318,7 +333,7 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} directoryServiceEvent :: DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () -directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \case +directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests, serviceRequestsInFlight} user@User {userId} cc = \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner @@ -344,8 +359,64 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o SDRUser -> deUserCommand ct ciId cmd SDRAdmin -> deAdminCommand ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd + DEServiceRequest reqId req -> deServiceRequest reqId req DELogChatResponse r -> logInfo r where + deServiceRequest :: AgentInvId -> J.Object -> IO () + deServiceRequest reqId req = do + accepted <- atomically $ stateTVar serviceRequestsInFlight $ \n -> + if n < maxServiceRequestsInFlight then (True, n + 1) else (False, n) + if accepted + then void $ forkIO $ (respond =<< requestResponse) `finally` releaseSlot + else reject "service is busy" + where + releaseSlot = atomically $ modifyTVar' serviceRequestsInFlight (subtract 1) + -- rejecting is cheaper than answering and fails the caller immediately + reject reason = + sendChatCmd cc (APIRejectServiceRequest userId reqId $ Just reason) >>= \case + Right _ -> pure () + Left e -> logError $ "service reject error: " <> tshow e + requestResponse = case JT.parseMaybe JT.parseJSON (J.Object req) of + Nothing -> pure $ DRError "unsupported request" + Just DRSearch {searchText, searchCursor} -> directorySearch searchText searchCursor + respond resp = case J.toJSON resp of + J.Object o -> + sendChatCmd cc (APISendServiceResponse userId reqId o) >>= \case + Right _ -> pure () + Left e -> logError $ "service response error: " <> tshow e + _ -> logError "service response is not an object" + directorySearch :: Text -> Maybe SearchCursor -> IO DirectoryResponse + directorySearch searchText cursor_ = + searchListedGroups cc user (STSearch searchText) cursor_ searchResults >>= \case + Left e -> logError ("searchListedGroups error: " <> T.pack e) $> DRError "search failed" + Right (gs, _) -> + getGroupLinks cc user (map fst gs) >>= \case + Left e -> logError ("getGroupLinks error: " <> T.pack e) $> DRError "search failed" + Right links -> do + now <- getCurrentTime + -- rows without a link are dropped, so entries and their cursors must stay paired + let rows = [(gr, e) | (gr, Just e) <- zipWith (\gr@(g, _) l -> (gr, searchEntry now g l)) gs links] + pure $ searchResults_ $ fitRows rows + where + -- send as many entries as the padded envelope allows; a lone entry that does not fit + -- is sent without its image, so paging always makes progress + fitRows [] = [] + fitRows rows + | fits rows = rows + | [(gr, e)] <- rows = [(gr, dropImage e)] + | otherwise = fitRows $ init rows + dropImage :: DirectorySearchEntry -> DirectorySearchEntry + dropImage e = e {image = Nothing} + fits = isRight . compressServiceBody . LB.toStrict . J.encode . searchResults_ + searchResults_ rows = + DRSearchResults + { entries = map snd rows, + -- the cursor is the last row actually sent, so truncated rows are not skipped + searchCursor = rowCursor . fst <$> lastMaybe rows + } + lastMaybe = foldl' (\_ x -> Just x) Nothing + rowCursor (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, GroupReg {createdAt}) = + SearchCursor {lastMembers = currentMembers, lastCreatedAt = createdAt, lastGroupId = groupId} groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt $ simplexChatContact cReq) strEncodeTxt sLnk_ withAdminUsers action = void . forkIO $ do forM_ superUsers $ \KnownContact {contactId} -> action contactId diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 0be86b6498..f55149e745 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -38,6 +38,7 @@ module Directory.Store listPendingGroups, getAllListedGroups, getAllListedGroups_, + getGroupLinks, searchListedGroups, verifiedGroupDomain, groupRegStatusText, @@ -340,6 +341,12 @@ getAllListedGroups_ db cxt user@User {userId, userContactId} = do where withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g) +-- only the RPC search needs links, so they are read for the returned page rather than in the search query +getGroupLinks :: ChatController -> User -> [GroupInfo] -> IO (Either String [Maybe GroupLink]) +getGroupLinks cc user gs = + withDB' "getGroupLinks" cc $ \db -> + mapM (\g -> eitherToMaybe <$> runExceptT (getGroupLink db user g)) gs + searchListedGroups :: ChatController -> User -> SearchType -> Maybe SearchCursor -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int)) searchListedGroups cc user@User {userId, userContactId} searchType cursor_ pageSize = withDB' "searchListedGroups" cc $ \db -> do diff --git a/plans/2026-08-04-directory-search-in-app.md b/plans/2026-08-04-directory-search-in-app.md index 297425fd1c..1d364c3215 100644 --- a/plans/2026-08-04-directory-search-in-app.md +++ b/plans/2026-08-04-directory-search-in-app.md @@ -42,11 +42,14 @@ Entry differences from `DirectoryEntry`: `welcomeMessage` dropped (it carries th **The response MUST be compressed, exactly as conn info is.** A service response is the same payload class as conn info — both are padded to `e2eEncConnInfoLength` — and the chat layer already compresses that class: `encodeConnInfoPQ` (Internal.hs:2250-2261) compresses with `compressedBatchMsgBody_` when PQ is on and the body exceeds `maxCompressedInfoLength` = **10,968** (Protocol.hs:939-940, defined as `maxEncodedInfoLength - 3726, see e2eEncConnInfoLength in agent`), and fails over the cap after compressing. The service path must do the same: -- directory side: encode the response JSON, compress with `compressedBatchMsgBody_` (Protocol.hs:1005, marker `'X'`) when over `maxCompressedInfoLength`, and treat still-over-cap as an internal error rather than attempting the send; -- requester side: `APISendServiceRequest` currently decodes the reply as raw JSON (`J.eitherDecodeStrict' respData`, Commands.hs:1455) and must first undo the marker and `decompress1`, mirroring the chat parser at Protocol.hs:957 (`'X' -> decodeCompressed`). `compress1`/`decompress1` are agent-side (`Simplex.Messaging.Compression`), so both ends already have them. Apply the same to the request direction (Subscriber.hs:1369) for symmetry, though search requests are far below the cap. +Compression belongs in the **core**, not in the directory: `APISendServiceResponse` takes a `J.Object` (Controller.hs:415) and encodes it itself, so a handler has no way to hand it compressed bytes. It is also generic — any service, not just the directory, needs it. `compressServiceBody` / `decompressServiceBody` (Protocol.hs, beside `compressedBatchMsgBody_`) wrap the same `'X'` marker and `maxCompressedInfoLength` bound, and are applied symmetrically at all four points: request encode and response decode in `APISendServiceRequest`, response encode in `APISendServiceResponse`, and request decode on the `SREQ` path (Subscriber.hs). A JSON payload never starts with `'X'`, so the marker is unambiguous and payloads under the bound stay uncompressed. + +Decompression MUST bound the expanded size against `maxDecompressedMsgLength` — without it a small payload from an untrusted peer can expand without limit. `10968` is the constant to size against, not the raw 11,106 — it is the chat layer's already-correct expression of the same agent limit. +The directory handler and the apps therefore see plain JSON and do nothing about compression. + **Entries per page is still bounded by images.** `image` is base64 of already-compressed JPEG/PNG, so compression recovers roughly the base64 expansion and no more: a near-cap 12,500-character image lands at roughly 9,400 bytes, against a 10,968 budget. One image-bearing entry per response; two will not fit whatever the page size. `searchResults` (default 10) is therefore not the binding constraint — the envelope is. The app shows whatever fits and pages the rest manually (§6); streaming the response is the eventual fix and is out of scope here. **Handler.** Add `DEServiceRequest` to `DirectoryEvent` (Events.hs:48) and a `CEvtServiceRequest` case to `crDirectoryEvent_` (:81); in `directoryServiceEvent` (Service.hs:321) decode, search, reply with `APISendServiceResponse`. Malformed JSON never reaches the bot — the core rejects it before emitting the event (Subscriber.hs:1367-1374), so the handler only ever sees a well-formed object and only has to answer for a wrong shape or unknown method, which returns the error envelope, never a chat message. The response must likewise be a JSON object: the core decodes it into `J.Object` and fails the whole call otherwise (Commands.hs:1455). diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 51f2ac8e91..2e8416547f 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -523,6 +523,7 @@ executable simplex-directory-service Directory.Events Directory.Listing Directory.Options + Directory.Rpc Directory.Search Directory.Service Directory.Store @@ -628,6 +629,7 @@ test-suite simplex-chat-test Directory.Events Directory.Listing Directory.Options + Directory.Rpc Directory.Search Directory.Service Directory.Store diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e8392b8c42..e92bdc5655 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -413,6 +413,7 @@ data ChatCommand | APIRejectContact {contactReqId :: Int64, notify :: Bool} | APISendServiceRequest {userId :: UserId, sendTarget :: ConnectTarget 'CMContact, requestTimeout :: Maybe NominalDiffTime, signKey :: Maybe (C.StoredPrivateKey 'C.Ed25519), request :: J.Object} | APISendServiceResponse {userId :: UserId, requestId :: AgentInvId, responseData :: J.Object} + | APIRejectServiceRequest {userId :: UserId, requestId :: AgentInvId, rejectionReason :: Maybe Text} | APISendCallInvitation ContactId CallType | SendCallInvitation ContactName CallType | APIRejectCall ContactId diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 8a41e7c655..65412a1ed9 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1451,8 +1451,9 @@ processChatCommand cxt nm = \case pure $ CRContactRequestRejected user cReq ct_ APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user -> do cReq <- resolveServiceTarget user sendTarget - respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) (LB.toStrict $ J.encode request) - resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData + reqData <- either throwCmdError pure $ compressServiceBody $ LB.toStrict $ J.encode request + respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) reqData + resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' =<< decompressServiceBody respData pure $ CRServiceResponse user resp where resolveServiceTarget user = \case @@ -1471,8 +1472,15 @@ processChatCommand cxt nm = \case resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk APISendServiceResponse userId requestId responseData -> withUserId userId $ \user -> do let AgentInvId invId = requestId - connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData) + respData <- either throwCmdError pure $ compressServiceBody $ LB.toStrict $ J.encode responseData + connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId respData pure $ CRServiceReplyAccepted user (AgentConnId connId) + APIRejectServiceRequest userId requestId reason -> withUserId userId $ \user -> do + let AgentInvId invId = requestId + -- a reason is required for the requester to fail fast; without it the request is + -- dropped silently and the caller waits out its timeout + withAgent $ \a -> rejectServiceRequest a NRMInteractive (aUserId user) invId (encodeUtf8 <$> reason) + ok user APISendCallInvitation contactId callType -> withUser $ \user -> do -- party initiating call ct <- withFastStore $ \db -> getContact db cxt user contactId @@ -5522,6 +5530,7 @@ chatCommandP = "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)), "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP), "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP), + "/_reject_service_request " *> (APIRejectServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (A.space *> (safeDecodeUtf8 <$> A.takeByteString))), "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP), "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType), "/_call reject @" *> (APIRejectCall <$> A.decimal), diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 6e798f7ab2..f96aea6ac4 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -1366,7 +1366,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = _ -> pure () SREQ invId sigKey_ payload -> chatReadVar processServiceRequests >>= \case - True -> case J.eitherDecodeStrict' payload of + True -> case J.eitherDecodeStrict' =<< decompressServiceBody payload of Right request -> toView $ CEvtServiceRequest user (AgentInvId invId) sigKey_ request Left _ -> dropSReq False -> dropSReq diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 8d9c8ecfcc..fb519cc4a6 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -1009,6 +1009,30 @@ markCompressedBatch :: ByteString -> ByteString markCompressedBatch = B.cons 'X' {-# INLINE markCompressedBatch #-} +-- Service payloads are padded to e2eEncConnInfoLength, the same budget as connection info, +-- so they use the compression, marker and size bound of encodeConnInfoPQ. A JSON payload +-- never starts with 'X', so the marker is unambiguous. +compressServiceBody :: ByteString -> Either String ByteString +compressServiceBody body + | B.length body <= maxCompressedInfoLength = Right body + | B.length body' > maxCompressedInfoLength = Left "service payload is too large" + | otherwise = Right body' + where + body' = compressedBatchMsgBody_ body + +decompressServiceBody :: ByteString -> Either String ByteString +decompressServiceBody body = case B.uncons body of + Nothing -> Left "empty service payload" + Just ('X', body') -> case smpDecode body' :: Either String (L.NonEmpty Compressed) of + Left e -> Left e + Right (c L.:| []) -> case decompressedSize c of + -- the bound is required: without it a small payload can expand to an unbounded one + Just size | size > maxDecompressedMsgLength -> Left "decompressed size exceeds limit" + Just _ -> decompress1 c + Nothing -> Left "compressed size not specified" + Right _ -> Left "unexpected compressed batch" + _ -> Right body + justTrue :: Bool -> Maybe Bool justTrue True = Just True justTrue False = Nothing diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index a71f92e335..c5b4917335 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -45,6 +45,7 @@ directoryServiceTests = do it "should support group names with spaces" testGroupNameWithSpaces it "should return more groups in search, all and recent groups" testSearchGroups it "should page from the sort key, not group ID" testSearchGroupsPaging + it "should answer search over service RPC" testDirectorySearchRpc it "should invite to owners' group if specified" testInviteToOwnersGroup it "should re-invite owner who left owners' group" testInviteOwnerAfterLeavingOwnersGroup describe "de-listing the group" $ do @@ -156,7 +157,7 @@ viewName = T.unpack . MD.viewName . T.pack testDirectoryService :: HasCallStack => TestParams -> IO () testDirectoryService ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -277,7 +278,7 @@ testDirectoryService ps = testSuspendResume :: HasCallStack => TestParams -> IO () testSuspendResume ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" @@ -349,7 +350,7 @@ testSuspendResume ps = testDeleteGroup :: HasCallStack => TestParams -> IO () testDeleteGroup ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" @@ -361,7 +362,7 @@ testDeleteGroup ps = testDeleteGroupAdmin :: HasCallStack => TestParams -> IO () testDeleteGroupAdmin ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -395,7 +396,7 @@ testDeleteGroupAdmin ps = testSetRole :: HasCallStack => TestParams -> IO () testSetRole ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -432,7 +433,7 @@ testSetRole ps = testJoinGroup :: HasCallStack => TestParams -> IO () testJoinGroup ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> do @@ -488,7 +489,7 @@ testJoinGroup ps = testGroupNameWithSpaces :: HasCallStack => TestParams -> IO () testGroupNameWithSpaces ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroup superUser bob "Privacy & Security" "" @@ -506,7 +507,7 @@ testGroupNameWithSpaces ps = testSearchGroups :: HasCallStack => TestParams -> IO () testSearchGroups ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -594,7 +595,7 @@ testSearchGroups ps = -- group has the most members, so it sorts first, and a group_id cursor would send it again. testSearchGroupsPaging :: HasCallStack => TestParams -> IO () testSearchGroupsPaging ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -652,9 +653,25 @@ testSearchGroupsPaging ps = u <##. "Link to join the group " u <## (show count <> " members") +-- the app path: a client that is not a contact searches the directory over the service RPC +testDirectorySearchRpc :: HasCallStack => TestParams -> IO () +testDirectorySearchRpc ps = + withDirectoryService ps $ \superUser (dsShortLink, _) -> + withNewTestChat ps "bob" bobProfile $ \bob -> do + bob `connectVia` dsShortLink + registerGroupId superUser bob "PrivacyGroup" "" 1 1 + withNewTestChat ps "cath" cathProfile $ \cath -> do + -- cath never connects to the directory: the request goes to the address + cath ##> ("/_service_request 1 " <> dsShortLink <> " {\"type\":\"search\",\"searchText\":\"privacy\"}") + cath <##. "service response: {\"entries\":[{" + cath ##> ("/_service_request 1 " <> dsShortLink <> " {\"type\":\"search\",\"searchText\":\"nothing matches this\"}") + cath <## "service response: {\"entries\":[],\"type\":\"searchResults\"}" + cath ##> ("/_service_request 1 " <> dsShortLink <> " {\"type\":\"nonsense\"}") + cath <## "service response: {\"errorMessage\":\"unsupported request\",\"type\":\"error\"}" + testInviteToOwnersGroup :: HasCallStack => TestParams -> IO () testInviteToOwnersGroup ps = - withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser dsLink -> + withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroupId superUser bob "privacy" "Privacy" 2 1 @@ -672,7 +689,7 @@ testInviteToOwnersGroup ps = testInviteOwnerAfterLeavingOwnersGroup :: HasCallStack => TestParams -> IO () testInviteOwnerAfterLeavingOwnersGroup ps = - withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser dsLink -> + withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroupId superUser bob "privacy" "Privacy" 2 1 @@ -698,7 +715,7 @@ testInviteOwnerAfterLeavingOwnersGroup ps = testDelistedOwnerLeaves :: HasCallStack => TestParams -> IO () testDelistedOwnerLeaves ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -717,7 +734,7 @@ testDelistedOwnerLeaves ps = testDelistedOwnerRemoved :: HasCallStack => TestParams -> IO () testDelistedOwnerRemoved ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -735,7 +752,7 @@ testDelistedOwnerRemoved ps = testNotDelistedMemberLeaves :: HasCallStack => TestParams -> IO () testNotDelistedMemberLeaves ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -750,7 +767,7 @@ testNotDelistedMemberLeaves ps = testNotDelistedMemberRemoved :: HasCallStack => TestParams -> IO () testNotDelistedMemberRemoved ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -764,7 +781,7 @@ testNotDelistedMemberRemoved ps = testDelistedServiceRemoved :: HasCallStack => TestParams -> IO () testDelistedServiceRemoved ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -782,7 +799,7 @@ testDelistedServiceRemoved ps = testDelistedGroupDeleted :: HasCallStack => TestParams -> IO () testDelistedGroupDeleted ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -806,7 +823,7 @@ testDelistedGroupDeleted ps = testDelistedRoleChanges :: HasCallStack => TestParams -> IO () testDelistedRoleChanges ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -855,7 +872,7 @@ testDelistedRoleChanges ps = testNotDelistedMemberRoleChanged :: HasCallStack => TestParams -> IO () testNotDelistedMemberRoleChanged ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -872,7 +889,7 @@ testNotDelistedMemberRoleChanged ps = testNotSentApprovalBadRoles :: HasCallStack => TestParams -> IO () testNotSentApprovalBadRoles ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -895,7 +912,7 @@ testNotSentApprovalBadRoles ps = testNotApprovedBadRoles :: HasCallStack => TestParams -> IO () testNotApprovedBadRoles ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -922,7 +939,7 @@ testNotApprovedBadRoles ps = testRegOwnerChangedProfile :: HasCallStack => TestParams -> IO () testRegOwnerChangedProfile ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -944,7 +961,7 @@ testRegOwnerChangedProfile ps = testAnotherOwnerChangedProfile :: HasCallStack => TestParams -> IO () testAnotherOwnerChangedProfile ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -966,7 +983,7 @@ testAnotherOwnerChangedProfile ps = testNotConnectedOwnerChangedProfile :: HasCallStack => TestParams -> IO () testNotConnectedOwnerChangedProfile ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do withNewTestChat ps "dan" danProfile $ \dan -> do @@ -987,7 +1004,7 @@ testNotConnectedOwnerChangedProfile ps = testRegOwnerRemovedLink :: HasCallStack => TestParams -> IO () testRegOwnerRemovedLink ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1024,7 +1041,7 @@ testRegOwnerRemovedLink ps = testAnotherOwnerRemovedLink :: HasCallStack => TestParams -> IO () testAnotherOwnerRemovedLink ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1060,7 +1077,7 @@ testAnotherOwnerRemovedLink ps = testNotConnectedOwnerRemovedLink :: HasCallStack => TestParams -> IO () testNotConnectedOwnerRemovedLink ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do withNewTestChat ps "dan" danProfile $ \dan -> do @@ -1104,7 +1121,7 @@ testNotConnectedOwnerRemovedLink ps = testDuplicateAskConfirmation :: HasCallStack => TestParams -> IO () testDuplicateAskConfirmation ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1123,7 +1140,7 @@ testDuplicateAskConfirmation ps = testDuplicateProhibitRegistration :: HasCallStack => TestParams -> IO () testDuplicateProhibitRegistration ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1135,7 +1152,7 @@ testDuplicateProhibitRegistration ps = testDuplicateProhibitConfirmation :: HasCallStack => TestParams -> IO () testDuplicateProhibitConfirmation ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1154,7 +1171,7 @@ testDuplicateProhibitConfirmation ps = testDuplicateProhibitWhenUpdated :: HasCallStack => TestParams -> IO () testDuplicateProhibitWhenUpdated ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1185,7 +1202,7 @@ testDuplicateProhibitWhenUpdated ps = testDuplicateProhibitApproval :: HasCallStack => TestParams -> IO () testDuplicateProhibitApproval ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1211,7 +1228,7 @@ testDuplicateProhibitApproval ps = testListUserGroups :: HasCallStack => Bool -> TestParams -> IO () testListUserGroups promote ps = - withDirectoryServiceCfgOwnersGroup ps testCfg False (Just "./tests/tmp/web") $ \superUser dsLink -> + withDirectoryServiceCfgOwnersGroup ps testCfg False (Just "./tests/tmp/web") $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1286,7 +1303,7 @@ checkListings listed promoted = do testAlwaysCaptcha :: HasCallStack => TestParams -> IO () testAlwaysCaptcha ps = - withDirectoryServiceOpts ps (\o -> o {alwaysCaptcha = True}) $ \superUser dsLink -> + withDirectoryServiceOpts ps (\o -> o {alwaysCaptcha = True}) $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1327,7 +1344,7 @@ testAlwaysCaptcha ps = testKnocking :: HasCallStack => TestParams -> IO () testKnocking ps = - withDirectoryServiceOpts ps (\o -> o {knocking = True}) $ \superUser dsLink -> + withDirectoryServiceOpts ps (\o -> o {knocking = True}) $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1350,7 +1367,7 @@ testKnocking ps = testCaptchaByDefault :: HasCallStack => TestParams -> IO () testCaptchaByDefault ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1382,7 +1399,7 @@ testCaptchaByDefault ps = testCapthaScreening :: HasCallStack => TestParams -> IO () testCapthaScreening ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1470,7 +1487,7 @@ testVoiceCaptchaScreening ps@TestParams {tmpPath} = do "print(5)" ] setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions - withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink -> + withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1530,7 +1547,7 @@ testVoiceCaptchaRetry ps@TestParams {tmpPath} = do "print(5)" ] setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions - withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink -> + withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1582,7 +1599,7 @@ testVoiceCaptchaVoiceDisabled ps@TestParams {tmpPath} = do "print(5)" ] setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions - withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink -> + withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1640,7 +1657,7 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do "print(5)" ] setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions - withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink -> + withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChatCfg ps testCfg {chatVRange = (chatVRange testCfg) {maxVersion = prevVersion memberSupportVoiceVersion}} "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1682,28 +1699,28 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" -withDirectoryServiceOpts :: HasCallStack => TestParams -> (DirectoryOpts -> DirectoryOpts) -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceOpts :: HasCallStack => TestParams -> (DirectoryOpts -> DirectoryOpts) -> (TestCC -> (String, String) -> IO ()) -> IO () withDirectoryServiceOpts ps modOpts test = do - dsLink <- + dsLinks <- withNewTestChatCfg ps testCfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps testCfg "super_user" aliceProfile $ \superUser -> do connectUsers ds superUser - ds ##> "/ad" - getContactLink ds True + ds ##> "/ad pq_ratchet=on" + getContactLinks ds True let opts = modOpts $ mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing runDirectory testCfg opts $ withTestChatCfg ps testCfg "super_user" $ \superUser -> do superUser <## "subscribed 1 connections on server localhost" - test superUser dsLink + test superUser dsLinks -withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () withDirectoryServiceVoiceCaptcha ps voiceScript = withDirectoryServiceOpts ps (\o -> o {voiceCaptchaGenerator = Just voiceScript}) testRestoreDirectory :: HasCallStack => TestParams -> IO () testRestoreDirectory ps = do testListUserGroups False ps - restoreDirectoryService ps 11 $ \superUser _dsLink -> + restoreDirectoryService ps 11 $ \superUser (_, _dsLink) -> withTestChat ps "bob" $ \bob -> withTestChat ps "cath" $ \cath -> do bob <## "subscribed 5 connections on server localhost" @@ -1808,15 +1825,17 @@ addCathAsOwner bob cath = do joinGroup "privacy" cath bob cath <## "#privacy: member 'SimpleX Directory' is connected" -withDirectoryService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO () +withDirectoryService :: HasCallStack => TestParams -> (TestCC -> (String, String) -> IO ()) -> IO () withDirectoryService ps = withDirectoryServiceCfg ps testCfg -withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> (String, String) -> IO ()) -> IO () withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False Nothing -withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () +-- the short link is the only form that carries the address DR keys, so service request tests +-- need it; tests that only connect take the full link and void the other +withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do - dsLink <- + dsLinks <- withNewTestChatCfg ps cfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps cfg "super_user" aliceProfile $ \superUser -> do connectUsers ds superUser @@ -1832,33 +1851,33 @@ withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do ds ##> "/j owners" ds <## "#owners: you joined the group" superUser <## "#owners: 'SimpleX Directory' joined the group" - ds ##> "/ad" - getContactLink ds True - withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test + ds ##> "/ad pq_ratchet=on" + getContactLinks ds True + withDirectoryOwnersGroup ps cfg dsLinks createOwnersGroup webFolder test -restoreDirectoryService :: HasCallStack => TestParams -> Int -> (TestCC -> String -> IO ()) -> IO () +restoreDirectoryService :: HasCallStack => TestParams -> Int -> (TestCC -> (String, String) -> IO ()) -> IO () restoreDirectoryService ps connCount test = do - dsLink <- + dsLinks <- withTestChat ps serviceDbPrefix $ \ds -> do ds .<## ("subscribed " <> show connCount <> " connections on server localhost") ds ##> "/sa" - dsLink <- getContactLink ds False + dsLinks <- getContactLinks ds False ds <## "auto_accept on" - pure dsLink - withDirectory ps testCfg dsLink test + pure dsLinks + withDirectory ps testCfg dsLinks test -withDirectory :: HasCallStack => TestParams -> ChatConfig -> String -> (TestCC -> String -> IO ()) -> IO () -withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False Nothing +withDirectory :: HasCallStack => TestParams -> ChatConfig -> (String, String) -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectory ps cfg dsLinks = withDirectoryOwnersGroup ps cfg dsLinks False Nothing -withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () -withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do +withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> (String, String) -> Bool -> Maybe FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryOwnersGroup ps cfg dsLinks createOwnersGroup webFolder test = do let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] (if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing) webFolder runDirectory cfg opts $ withTestChatCfg ps cfg "super_user" $ \superUser -> do if createOwnersGroup then superUser <## "subscribed 2 connections on server localhost" else superUser <## "subscribed 1 connections on server localhost" - test superUser dsLink + test superUser dsLinks runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO () runDirectory cfg opts action = do @@ -2019,7 +2038,7 @@ groupNotFound_ suffix u s = do testCaptchaTooManyAttempts :: HasCallStack => TestParams -> IO () testCaptchaTooManyAttempts ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -2057,7 +2076,7 @@ testCaptchaTooManyAttempts ps = testCaptchaUnknownCommand :: HasCallStack => TestParams -> IO () testCaptchaUnknownCommand ps = - withDirectoryService ps $ \superUser dsLink -> + withDirectoryService ps $ \superUser (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -2083,7 +2102,7 @@ testCaptchaUnknownCommand ps = testHelpNoAudio :: HasCallStack => TestParams -> IO () testHelpNoAudio ps = - withDirectoryService ps $ \_ dsLink -> + withDirectoryService ps $ \_ (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink -- commands help should not mention /audio @@ -2100,7 +2119,7 @@ testHelpNoAudio ps = testAudioCommandInDM :: HasCallStack => TestParams -> IO () testAudioCommandInDM ps = - withDirectoryService ps $ \_ dsLink -> + withDirectoryService ps $ \_ (_, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink bob #> "@'SimpleX Directory' /audio" @@ -2109,7 +2128,7 @@ testAudioCommandInDM ps = testRegisterChannelViaCard :: HasCallStack => TestParams -> IO () testRegisterChannelViaCard ps = - withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do -- bob connects to directory service first @@ -2188,7 +2207,7 @@ testRegisterChannelViaCard ps = -- owner sets a name; directory verifies name<->link consistency and shows the verified name to the admin testDirectoryChannelName :: HasCallStack => TestParams -> IO () testDirectoryChannelName ps = withSmpServerAndNames $ \reg -> - withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do enableNamesRole bob @@ -2229,7 +2248,7 @@ testDirectoryChannelName ps = withSmpServerAndNames $ \reg -> -- registry re-pointed to a different link after the owner set the name: directory verification fails testDirectoryChannelNameNotVerified :: HasCallStack => TestParams -> IO () testDirectoryChannelNameNotVerified ps = withSmpServerAndNames $ \reg -> - withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do enableNamesRole bob @@ -2270,7 +2289,7 @@ testDirectoryChannelNameNotVerified ps = withSmpServerAndNames $ \reg -> testLinkAsTextSearch :: HasCallStack => TestParams -> IO () testLinkAsTextSearch ps = - withDirectoryServiceCfg ps testCfg $ \_superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \_superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do bob `connectVia` dsLink @@ -2282,7 +2301,7 @@ testLinkAsTextSearch ps = testNonOwnerSharesCard :: HasCallStack => TestParams -> IO () testNonOwnerSharesCard ps = - withDirectoryServiceCfg ps testCfg $ \_superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \_superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> withNewTestChatCfg ps testCfg "cath" cathProfile $ \cath -> do @@ -2297,7 +2316,7 @@ testNonOwnerSharesCard ps = testDeleteChannelRegistration :: HasCallStack => TestParams -> IO () testDeleteChannelRegistration ps = - withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do bob `connectVia` dsLink @@ -2342,7 +2361,7 @@ testDeleteChannelRegistration ps = testReregistrationAlreadyListed :: HasCallStack => TestParams -> IO () testReregistrationAlreadyListed ps = - withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> + withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do bob `connectVia` dsLink diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 63dbea549f..8b86554fd1 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -7,8 +7,10 @@ module ProtocolTests where +import Control.Concurrent.STM (atomically) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Simplex.Chat.Library.Internal (decodeLinkUserData, encodeShortLinkData) import Simplex.Chat.Protocol @@ -27,6 +29,29 @@ protocolTests :: Spec protocolTests = do decodeChatMessageTest shortLinkDataTests + serviceBodyTests + +serviceBodyTests :: Spec +serviceBodyTests = describe "service payload compression" $ do + it "passes a small payload through uncompressed" $ do + let payload = "{\"ping\":1}" + compressServiceBody payload `shouldBe` Right payload + decompressServiceBody payload `shouldBe` Right payload + it "compresses a payload over the size bound and restores it" $ do + let payload = "{\"pong\":\"" <> B.replicate 12000 'a' <> "\"}" + compressed <- either fail pure $ compressServiceBody payload + B.length compressed `shouldSatisfy` (<= maxCompressedInfoLength) + B.head compressed `shouldBe` 'X' + decompressServiceBody compressed `shouldBe` Right payload + it "rejects a payload that is too large even compressed" $ do + -- random bytes do not compress, so this stays over the bound + g <- C.newRandom + payload <- atomically $ C.randomBytes (maxCompressedInfoLength * 2) g + compressServiceBody payload `shouldBe` Left "service payload is too large" + it "rejects a payload that expands past the decompressed bound" $ do + let bomb = compressedBatchMsgBody_ $ B.replicate (maxDecompressedMsgLength + 1) 'a' + B.length bomb `shouldSatisfy` (< maxCompressedInfoLength) + decompressServiceBody bomb `shouldBe` Left "decompressed size exceeds limit" srv :: SMPServer srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")