From 44902c1425162b2be665c784b2bf0ea4022d4971 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 12 Oct 2026 18:58:40 +0000 Subject: [PATCH] review: round 1 fixes R1-1 add the service response to the exhaustive iOS and Kotlin response matches R1-3 directory search cursor carries only the sort value of its mode, so the RPC no longer sends registration times R1-4 a directory search does not take the progress spinner from a connection R1-6 directory entry type, name and rounded times defined once for listing and RPC R1-7 restore the directory test harness signatures of master, with link-pair variants for the new tests R1-8 tests: compressed service request through SREQ, reject without a reason --- apps/ios/Shared/Model/AppAPITypes.swift | 1 + apps/ios/Shared/Model/ChatModel.swift | 1 + .../chat/simplex/common/model/ChatModel.kt | 1 + .../chat/simplex/common/model/SimpleXAPI.kt | 2 + .../src/Directory/Listing.hs | 27 ++- .../src/Directory/Rpc.hs | 14 +- .../src/Directory/Search.hs | 16 +- .../src/Directory/Service.hs | 8 +- .../src/Directory/Store.hs | 26 ++- tests/Bots/DirectoryTests.hs | 187 ++++++++++-------- tests/ChatTests/Direct.hs | 59 +++++- 11 files changed, 217 insertions(+), 125 deletions(-) diff --git a/apps/ios/Shared/Model/AppAPITypes.swift b/apps/ios/Shared/Model/AppAPITypes.swift index 23692c0f55..be55a77895 100644 --- a/apps/ios/Shared/Model/AppAPITypes.swift +++ b/apps/ios/Shared/Model/AppAPITypes.swift @@ -985,6 +985,7 @@ enum ChatResponse1: Decodable, ChatAPIResult { case let .connectionIncognitoUpdated(u, toConnection): return withUser(u, String(describing: toConnection)) case let .connectionUserChanged(u, fromConnection, toConnection, newUser): return withUser(u, "fromConnection: \(String(describing: fromConnection))\ntoConnection: \(String(describing: toConnection))\nnewUserId: \(String(describing: newUser.userId))") case let .connectionPlan(u, connLink, _, _, connectionPlan): return withUser(u, "connLink: \(String(describing: connLink))\nconnectionPlan: \(String(describing: connectionPlan))") + case let .serviceResponse(u, responseData): return withUser(u, encodeJSON(responseData)) case let .newPreparedChat(u, chat): return withUser(u, String(describing: chat)) case let .contactUserChanged(u, fromContact, newUser, toContact): return withUser(u, "fromContact: \(String(describing: fromContact))\nnewUserId: \(String(describing: newUser.userId))\ntoContact: \(String(describing: toContact))") case let .groupUserChanged(u, fromGroup, newUser, toGroup): return withUser(u, "fromGroup: \(String(describing: fromGroup))\nnewUserId: \(String(describing: newUser.userId))\ntoGroup: \(String(describing: toGroup))") diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift index 89cc4089a1..8f9496976c 100644 --- a/apps/ios/Shared/Model/ChatModel.swift +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -314,6 +314,7 @@ class ConnectProgressManager: ObservableObject { static let shared = ConnectProgressManager() func startConnectProgress(_ text: String, owner: ConnectProgressOwner = .connect, onCancel: (() -> Void)? = nil) { + if owner == .directorySearch && self.owner == .connect { return } connectInProgress = text self.owner = owner self.onCancel = onCancel 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 5a0c052525..a4280e9d5b 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 @@ -58,6 +58,7 @@ object ConnectProgressManager { private val coroutineScope = CoroutineScope(SupervisorJob() + Dispatchers.Main) fun startConnectProgress(text: String, owner: ConnectProgressOwner = ConnectProgressOwner.Connect, onCancel: (() -> Unit)? = null) { + if (owner == ConnectProgressOwner.DirectorySearch && this.owner == ConnectProgressOwner.Connect) return connectInProgress.value = text this.owner = owner this.onCancel = onCancel 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 e8d0ff1b00..c6cd7c2e2d 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 @@ -6983,6 +6983,7 @@ sealed class CR { is ConnectionIncognitoUpdated -> "connectionIncognitoUpdated" is ConnectionUserChanged -> "ConnectionUserChanged" is CRConnectionPlan -> "connectionPlan" + is CRServiceResponse -> "serviceResponse" is NewPreparedChat -> "newPreparedChat" is ContactUserChanged -> "contactUserChanged" is GroupUserChanged -> "groupUserChanged" @@ -7175,6 +7176,7 @@ sealed class CR { is ConnectionIncognitoUpdated -> withUser(user, json.encodeToString(toConnection)) is ConnectionUserChanged -> withUser(user, "fromConnection: ${json.encodeToString(fromConnection)}\ntoConnection: ${json.encodeToString(toConnection)}\nnewUser: ${json.encodeToString(newUser)}" ) is CRConnectionPlan -> withUser(user, "connLink: ${json.encodeToString(connLink)}\nplanSimplexName: $planSimplexName\notherSimplexName: $otherSimplexName\nconnectionPlan: ${json.encodeToString(connectionPlan)}") + is CRServiceResponse -> withUser(user, json.encodeToString(responseData)) is NewPreparedChat -> withUser(user, json.encodeToString(chat)) is ContactUserChanged -> withUser(user, "fromContact: ${json.encodeToString(fromContact)}\nnewUserId: ${json.encodeToString(newUser.userId)}\ntoContact: ${json.encodeToString(toContact)}") is GroupUserChanged -> withUser(user, "fromGroup: ${json.encodeToString(fromGroup)}\nnewUserId: ${json.encodeToString(newUser.userId)}\ntoGroup: ${json.encodeToString(toGroup)}") diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs index fd78757978..9c2376588d 100644 --- a/apps/simplex-directory-service/src/Directory/Listing.hs +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -117,10 +117,9 @@ recentRoundedTime roundTo now t in Just $ systemToUTCTime $ MkSystemTime secs 0 groupDirectoryEntry :: UTCTime -> GroupInfo -> Maybe GroupLink -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData)) -groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSummary} gLink_ = - let GroupProfile {displayName, shortDescr, description, image, memberAdmission, publicGroup} = groupProfile - gt = (\PublicGroupProfile {groupType} -> groupType) <$> publicGroup - entryType = DETGroup gt memberAdmission groupSummary +groupDirectoryEntry now g@GroupInfo {groupProfile} gLink_ = + let GroupProfile {displayName, shortDescr, description, image, publicGroup} = groupProfile + entryType = groupEntryType g description' = case publicGroup of Just PublicGroupProfile {groupType = gt', groupLink = sLnk} -> let gtStr = case gt' of GTChannel -> "channel"; _ -> "group" @@ -138,13 +137,13 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma DirectoryEntry { entryType, displayName, - simplexName = shortNameInfoStr . SimplexNameInfo NTPublicGroup <$> verifiedGroupDomain g, + simplexName = groupSimplexName g, groupLink, shortDescr = toFormattedText <$> shortDescr, welcomeMessage = toFormattedText <$> description', imageFile = fst <$> imgData, - activeAt = recentRoundedTime 900 now $ fromMaybe createdAt chatTs, - createdAt = recentRoundedTime 86400 now createdAt + activeAt = groupActiveAt now g, + createdAt = groupCreatedAt now g } imgData = imgFileData groupLink =<< image in (de, imgData) @@ -173,6 +172,20 @@ groupPublicLink GroupInfo {groupProfile = GroupProfile {publicGroup}} gLink_ = c where toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink +-- what the web listing and the search RPC both publish about a group, defined once so their privacy rounding cannot diverge +groupEntryType :: GroupInfo -> DirectoryEntryType +groupEntryType GroupInfo {groupProfile = GroupProfile {memberAdmission, publicGroup}, groupSummary} = + DETGroup ((\PublicGroupProfile {groupType} -> groupType) <$> publicGroup) memberAdmission groupSummary + +groupSimplexName :: GroupInfo -> Maybe Text +groupSimplexName g = shortNameInfoStr . SimplexNameInfo NTPublicGroup <$> verifiedGroupDomain g + +groupActiveAt :: UTCTime -> GroupInfo -> Maybe UTCTime +groupActiveAt now GroupInfo {chatTs, createdAt} = recentRoundedTime 900 now $ fromMaybe createdAt chatTs + +groupCreatedAt :: UTCTime -> GroupInfo -> Maybe UTCTime +groupCreatedAt now GroupInfo {createdAt} = recentRoundedTime 86400 now createdAt + 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 index d55240c47e..b7b11c3563 100644 --- a/apps/simplex-directory-service/src/Directory/Rpc.hs +++ b/apps/simplex-directory-service/src/Directory/Rpc.hs @@ -18,11 +18,9 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Directory.Listing import Directory.Search -import Directory.Store import Simplex.Chat.Library.Commands (maxProfileImageSize) import Simplex.Chat.Protocol (compressServiceBody) import Simplex.Chat.Types -import Simplex.Messaging.SimplexName (SimplexNameInfo (..), SimplexNameType (..), shortNameInfoStr) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) data DirectoryRequest = DRSearch @@ -87,20 +85,20 @@ searchResultsPage rowCursor storeHasMore rows = fit entryRows lastMaybe = foldl' (\_ x -> Just x) Nothing searchEntry :: UTCTime -> GroupInfo -> Maybe GroupLink -> Maybe DirectorySearchEntry -searchEntry now g@GroupInfo {groupProfile, chatTs, createdAt = groupCreatedAt, groupSummary} gLink_ = +searchEntry now g@GroupInfo {groupProfile} gLink_ = entry <$> groupPublicLink g gLink_ where - GroupProfile {displayName, shortDescr, image, memberAdmission, publicGroup} = groupProfile + GroupProfile {displayName, shortDescr, image} = groupProfile entry link@PublicLink {connShortLink} = DirectorySearchEntry - { entryType = DETGroup ((\PublicGroupProfile {groupType} -> groupType) <$> publicGroup) memberAdmission groupSummary, + { entryType = groupEntryType g, displayName, - simplexName = shortNameInfoStr . SimplexNameInfo NTPublicGroup <$> verifiedGroupDomain g, + simplexName = groupSimplexName g, -- the apps connect through the short link, and a full link is hundreds of bytes of the envelope groupLink = if isJust connShortLink then link {connFullLink = Nothing} else link, shortDescr, -- an owner can put any size of image in the profile we store, so bound what we relay image = image >>= \img@(ImageData t) -> if T.length t > maxProfileImageSize then Nothing else Just img, - activeAt = recentRoundedTime 900 now $ fromMaybe groupCreatedAt chatTs, - createdAt = recentRoundedTime 86400 now groupCreatedAt + activeAt = groupActiveAt now g, + createdAt = groupCreatedAt now g } diff --git a/apps/simplex-directory-service/src/Directory/Search.hs b/apps/simplex-directory-service/src/Directory/Search.hs index 99d42ed94b..9fe54871d5 100644 --- a/apps/simplex-directory-service/src/Directory/Search.hs +++ b/apps/simplex-directory-service/src/Directory/Search.hs @@ -7,7 +7,7 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Types -import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) data SearchRequest = SearchRequest { searchType :: SearchType, @@ -15,14 +15,12 @@ data SearchRequest = SearchRequest searchCursor :: SearchCursor } --- Where the last page ended: each search mode reads the field it sorts by, and the group ID --- breaks ties, because member counts and timestamps are not unique. -data SearchCursor = SearchCursor - { lastMembers :: Int64, - lastCreatedAt :: UTCTime, - lastGroupId :: GroupId - } +-- Where the last page ended: the value the search mode sorts by, and the group ID that breaks ties. +-- The service RPC sends it to anyone, so it carries nothing else: text search must not reveal registration times. +data SearchCursor + = SCMembers {lastMembers :: Int64, lastGroupId :: GroupId} + | SCRecent {lastCreatedAt :: UTCTime, lastGroupId :: GroupId} data SearchType = STAll | STRecent | STSearch Text -$(JQ.deriveJSON defaultJSON ''SearchCursor) +$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SC") ''SearchCursor) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 94b73ac342..79a94ff66c 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -389,8 +389,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o now <- getCurrentTime pure $ searchResultsPage rowCursor (n > length gs) [(row, searchEntry now g gLink_) | row@(g, _, gLink_) <- gs] where - rowCursor (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, GroupReg {createdAt}, _) = - SearchCursor {lastMembers = currentMembers, lastCreatedAt = createdAt, lastGroupId = groupId} + rowCursor (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, _, _) = SCMembers currentMembers groupId groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt $ simplexChatContact cReq) strEncodeTxt sLnk_ withAdminUsers action = void . forkIO $ do forM_ superUsers $ \KnownContact {contactId} -> action contactId @@ -1295,7 +1294,10 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o updateSearchRequest :: SearchType -> (GroupInfo, GroupReg, Maybe CreatedLinkContact) -> IO () updateSearchRequest searchType (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, GroupReg {createdAt}, _) = do searchTime <- getCurrentTime - let searchCursor = SearchCursor {lastMembers = currentMembers, lastCreatedAt = createdAt, lastGroupId = groupId} + let searchCursor = case searchType of + STAll -> SCMembers currentMembers groupId + STRecent -> SCRecent createdAt groupId + STSearch _ -> SCMembers currentMembers groupId search = SearchRequest {searchType, searchTime, searchCursor} atomically $ TM.insert (contactId' ct) search searchRequests getRegisteredGroupByLink :: AConnectionLink -> IO (Maybe (GroupInfo, GroupReg, CreatedLinkContact)) diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 1662998b9d..c265092078 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -54,6 +54,7 @@ module Directory.Store ) where +import Control.Monad (join) import Control.Monad.Except import Control.Monad.IO.Class import Data.Aeson ((.:), (.=)) @@ -346,40 +347,43 @@ getAllListedGroups_ db cxt user@User {userId, userContactId} = do searchListedGroups :: ChatController -> User -> SearchType -> Maybe SearchCursor -> Int -> IO (Either String ([(GroupInfo, GroupReg, Maybe GroupLink)], Int)) searchListedGroups cc user@User {userId, userContactId} searchType cursor_ pageSize = - withDB' "searchListedGroups" cc $ \db -> do + fmap join . withDB' "searchListedGroups" cc $ \db -> do currentTs <- getCurrentTime case searchType of STAll -> case cursor_ of Nothing -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize) n <- count $ DB.query db countQuery' (Only GRSActive) - pure (gs, n) - Just SearchCursor {lastMembers, lastGroupId} -> do + pure $ Right (gs, n) + Just SCMembers {lastMembers, lastGroupId} -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersCond <> membersOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, lastMembers, lastMembers, lastGroupId, pageSize) n <- count $ DB.query db (countQuery' <> membersCond) (GRSActive, lastMembers, lastMembers, lastGroupId) - pure (gs, n) + pure $ Right (gs, n) + Just SCRecent {} -> pure wrongCursor where countQuery' = countQuery <> " WHERE r.group_reg_status = ? " STRecent -> case cursor_ of Nothing -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> recentOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize) n <- count $ DB.query db countQuery' (Only GRSActive) - pure (gs, n) - Just SearchCursor {lastCreatedAt, lastGroupId} -> do + pure $ Right (gs, n) + Just SCRecent {lastCreatedAt, lastGroupId} -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> recentCond <> recentOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, lastCreatedAt, lastCreatedAt, lastGroupId, pageSize) n <- count $ DB.query db (countQuery' <> recentCond) (GRSActive, lastCreatedAt, lastCreatedAt, lastGroupId) - pure (gs, n) + pure $ Right (gs, n) + Just SCMembers {} -> pure wrongCursor where countQuery' = countQuery <> " WHERE r.group_reg_status = ? " STSearch search -> case cursor_ of Nothing -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> searchCond <> membersOrderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, s, s, s, s) :. (sDomain, pageSize)) n <- count $ DB.query db (countQuery' <> searchCond) (GRSActive, s, s, s, s, sDomain) - pure (gs, n) - Just SearchCursor {lastMembers, lastGroupId} -> do + pure $ Right (gs, n) + Just SCMembers {lastMembers, lastGroupId} -> do gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersCond <> searchCond <> membersOrderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, lastMembers, lastMembers, lastGroupId) :. (s, s, s, s, sDomain, pageSize)) n <- count $ DB.query db (countQuery' <> membersCond <> searchCond) ((GRSActive, lastMembers, lastMembers, lastGroupId) :. (s, s, s, s, sDomain)) - pure (gs, n) + pure $ Right (gs, n) + Just SCRecent {} -> pure wrongCursor where s = likeEscape $ T.toLower search -- a bare "#"/"@" maps to "#", matching no stored domain (domains are stored unprefixed) @@ -390,6 +394,8 @@ searchListedGroups cc user@User {userId, userContactId} searchType cursor_ pageS where groups currentTs = (map (toGroupInfoRegLink currentTs (storeCxt cc) user) <$>) count = maybeFirstRow' 0 fromOnly + -- only a forged request pairs a mode with another mode's cursor: restarting from the first page would make a client loop + wrongCursor = Left "search cursor does not match the search type" listedGroupQuery = groupReqQuery <> " AND r.group_reg_status = ? " countQuery = "SELECT COUNT(1) FROM groups g JOIN sx_directory_group_regs r ON g.group_id = r.group_id " -- the cursor conditions must stay paired with the order by of the same sort key: diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index b587b748b0..f0ad4b16e7 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -199,7 +199,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 @@ -289,7 +289,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" @@ -356,7 +356,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" @@ -368,7 +368,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 @@ -402,7 +402,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 @@ -438,7 +438,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 @@ -491,7 +491,7 @@ testJoinGroup ps = testSearchByLink :: HasCallStack => TestParams -> IO () testSearchByLink ps = - withDirectoryService ps $ \superUser (_, dsLink) -> + withDirectoryService ps $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" @@ -532,7 +532,7 @@ testSearchByLink 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" "" @@ -550,7 +550,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 @@ -637,7 +637,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 @@ -696,7 +696,7 @@ testSearchGroupsPaging ps = testDirectorySearchRpc :: HasCallStack => TestParams -> IO () testDirectorySearchRpc ps = - withDirectoryService ps $ \superUser (dsShortLink, _) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, _) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsShortLink registerGroupId superUser bob "PrivacyGroup" "" 1 1 @@ -715,21 +715,26 @@ testDirectorySearchRpc ps = -- the cursor is echoed back exactly as received, which is what the apps do with it testDirectorySearchRpcPaging :: HasCallStack => TestParams -> IO () testDirectorySearchRpcPaging ps = - withDirectoryService ps $ \superUser (dsShortLink, _) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, _) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsShortLink forM_ [1 .. 4 :: Int] $ \i -> registerGroupId superUser bob ("group" <> show i) "" i i withNewTestChat ps "cath" cathProfile $ \cath -> do (page1, cursor) <- searchNames cath dsShortLink "group" Nothing page1 `shouldBe` ["group1", "group2", "group3"] + -- anyone can send this request, so the cursor must not reveal when a group was registered + maybe "" (LB.unpack . J.encode) cursor `shouldNotContain` "lastCreatedAt" (page2, cursor') <- searchNames cath dsShortLink "group" cursor page2 `shouldBe` ["group4"] cursor' `shouldBe` Nothing + -- only a forged request pairs text search with a creation-time cursor, and it must not restart from the first page + cath ##> ("/_service_request 1 " <> dsShortLink <> " {\"type\":\"search\",\"searchText\":\"group\",\"searchCursor\":{\"type\":\"recent\",\"lastCreatedAt\":\"2026-01-01T00:00:00Z\",\"lastGroupId\":1}}") + cath <## "service response: {\"errorMessage\":\"search failed\",\"type\":\"error\"}" -- the search text is a substring: '%' and '_' in it match literally, and its length is bounded testDirectorySearchRpcLiteral :: HasCallStack => TestParams -> IO () testDirectorySearchRpcLiteral ps = - withDirectoryService ps $ \superUser (dsShortLink, _) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, _) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsShortLink registerGroupId superUser bob "PrivacyGroup" "" 1 1 @@ -755,7 +760,7 @@ testDirectorySearchRpcLiteral ps = -- over the cap a request is refused at once with a reason, so the requester does not wait out its timeout testDirectorySearchRpcBusy :: HasCallStack => TestParams -> IO () testDirectorySearchRpcBusy ps = - withDirectoryServiceOpts ps (\o -> o {maxServiceRequestsInFlight = 0}) $ \_superUser (dsShortLink, _) -> + withDirectoryServiceOptsLinks ps (\o -> o {maxServiceRequestsInFlight = 0}) $ \_superUser (dsShortLink, _) -> withNewTestChat ps "cath" cathProfile $ \cath -> do cath ##> ("/_service_request 1 " <> dsShortLink <> " {\"type\":\"search\",\"searchText\":\"privacy\"}") cath <## "smp agent error: AGENT {agentErr = A_SERVICE {serviceError = ASERejected {rejectReason = \"service is busy\"}}}" @@ -788,7 +793,7 @@ searchEntryOnly u dsLink text = do testDirectorySearchEntryFields :: HasCallStack => TestParams -> IO () testDirectorySearchEntryFields ps = - withDirectoryService ps $ \superUser (dsShortLink, dsLink) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroupWithImage superUser bob "PrivacyGroup" "Private chats" 1 @@ -812,7 +817,7 @@ testDirectorySearchEntryFields ps = -- a channel publishes its own link in the profile, so groupPublicLink takes the other branch testDirectorySearchChannelEntry :: HasCallStack => TestParams -> IO () testDirectorySearchChannelEntry ps = - withDirectoryServiceCfg ps testCfg $ \superUser (dsShortLink, dsLink) -> + withDirectoryServiceCfgLinks ps testCfg $ \superUser (dsShortLink, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do bob `connectVia` dsLink @@ -858,7 +863,7 @@ testSearchEntryImageBound ps = -- one entry with a large image nearly fills a response, so both groups match but only one is sent testDirectorySearchImagePaging :: HasCallStack => TestParams -> IO () testDirectorySearchImagePaging ps = - withDirectoryService ps $ \superUser (dsShortLink, dsLink) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroupWithImage superUser bob "photos1" "Photo group" 1 @@ -874,7 +879,7 @@ testDirectorySearchImagePaging ps = -- the link in a result actually works: this is what happens when a user taps a row in the app testDirectorySearchJoinGroup :: HasCallStack => TestParams -> IO () testDirectorySearchJoinGroup ps = - withDirectoryService ps $ \superUser (dsShortLink, dsLink) -> + withDirectoryServiceLinks ps $ \superUser (dsShortLink, dsLink) -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -965,10 +970,9 @@ channelFoundSubscribers u name = do testSearchResultsPage :: HasCallStack => TestParams -> IO () testSearchResultsPage _ps = do g <- C.newRandom - now <- getCurrentTime -- base64 of random bytes does not compress, so the envelope decides what fits let randomText n = safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes n g) - cursor gId = SearchCursor {lastMembers = 1, lastCreatedAt = now, lastGroupId = gId} + cursor gId = SCMembers {lastMembers = 1, lastGroupId = gId} page r = case r of DRSearchResults {entries, searchCursor} -> (map (\DirectorySearchEntry {displayName} -> displayName) entries, lastGroupId <$> searchCursor) DRError e -> error $ T.unpack e @@ -1000,7 +1004,7 @@ testSearchResultsPage _ps = do 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 @@ -1018,7 +1022,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 @@ -1046,7 +1050,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 @@ -1063,7 +1067,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 @@ -1084,7 +1088,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 @@ -1099,7 +1103,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 @@ -1118,7 +1122,7 @@ testNotDelistedMemberRemoved ps = -- modified client), then leaves that second membership while remaining the owner. testNotDelistedOwnerRejoinsViaLink :: HasCallStack => TestParams -> IO () testNotDelistedOwnerRejoinsViaLink ps = - withDirectoryService ps $ \superUser (_, dsLink) -> + withDirectoryService ps $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" @@ -1163,7 +1167,7 @@ testNotDelistedOwnerRejoinsViaLink 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 @@ -1181,7 +1185,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 @@ -1205,7 +1209,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 @@ -1258,7 +1262,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 @@ -1273,7 +1277,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 @@ -1299,7 +1303,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 @@ -1336,7 +1340,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 @@ -1355,7 +1359,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 @@ -1376,7 +1380,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 @@ -1398,7 +1402,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 @@ -1420,7 +1424,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 @@ -1444,7 +1448,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 @@ -1470,7 +1474,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 @@ -1490,7 +1494,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 @@ -1502,7 +1506,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 @@ -1521,7 +1525,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 @@ -1552,7 +1556,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 @@ -1578,7 +1582,7 @@ testDuplicateProhibitApproval ps = testListUserGroups :: HasCallStack => Bool -> TestParams -> IO () testListUserGroups promote ps = - withDirectoryServiceCfgOwnersGroup ps testCfg False (Just webDir) $ \superUser (_, dsLink) -> + withDirectoryServiceCfgOwnersGroup ps testCfg False (Just webDir) $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1641,7 +1645,7 @@ checkListings webDir listed promoted = 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 @@ -1681,7 +1685,7 @@ testAlwaysCaptcha ps = testAlwaysObserver :: HasCallStack => TestParams -> IO () testAlwaysObserver ps = - withDirectoryServiceOpts ps (\o -> o {alwaysObserver = True}) $ \superUser (_, dsLink) -> + withDirectoryServiceOpts ps (\o -> o {alwaysObserver = True}) $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink @@ -1709,7 +1713,7 @@ testAlwaysObserver 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 @@ -1732,7 +1736,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 @@ -1763,7 +1767,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 @@ -1849,7 +1853,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 @@ -1908,7 +1912,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 @@ -1960,7 +1964,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 @@ -2017,7 +2021,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 @@ -2058,8 +2062,11 @@ 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, String) -> IO ()) -> IO () -withDirectoryServiceOpts ps modOpts test = do +withDirectoryServiceOpts :: HasCallStack => TestParams -> (DirectoryOpts -> DirectoryOpts) -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceOpts ps modOpts test = withDirectoryServiceOptsLinks ps modOpts $ \superUser (_, dsLink) -> test superUser dsLink + +withDirectoryServiceOptsLinks :: HasCallStack => TestParams -> (DirectoryOpts -> DirectoryOpts) -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceOptsLinks ps modOpts test = do dsLinks <- withNewTestChatCfg ps testCfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps testCfg "super_user" aliceProfile $ \superUser -> do @@ -2072,14 +2079,14 @@ withDirectoryServiceOpts ps modOpts test = do superUser <## "subscribed 1 connections on server localhost" test superUser dsLinks -withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO () withDirectoryServiceVoiceCaptcha ps voiceScript test = withXFTPServer ps $ withDirectoryServiceOpts ps (\o -> o {voiceCaptchaGenerator = Just voiceScript}) test 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" @@ -2179,15 +2186,25 @@ addCathAsOwner bob cath = do joinGroup "privacy" cath bob cath <## "#privacy: member 'SimpleX Directory' is connected" -withDirectoryService :: HasCallStack => TestParams -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO () withDirectoryService ps = withDirectoryServiceCfg ps testCfg -withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceLinks :: HasCallStack => TestParams -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceLinks ps = withDirectoryServiceCfgLinks ps testCfg + +withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> String -> IO ()) -> IO () withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False Nothing --- passes both link forms: only the short one works for service requests, so those tests need it -withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () -withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do +withDirectoryServiceCfgLinks :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceCfgLinks ps cfg = withDirectoryServiceCfgOwnersGroupLinks ps cfg False Nothing + +withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = + withDirectoryServiceCfgOwnersGroupLinks ps cfg createOwnersGroup webFolder $ \superUser (_, dsLink) -> test superUser dsLink + +-- service request tests need the short link: only it carries the address ratchet keys +withDirectoryServiceCfgOwnersGroupLinks :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () +withDirectoryServiceCfgOwnersGroupLinks ps cfg createOwnersGroup webFolder test = do dsLinks <- withNewTestChatCfg ps cfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps cfg "super_user" aliceProfile $ \superUser -> do @@ -2208,29 +2225,29 @@ withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do getContactLinks ds True withDirectoryOwnersGroup ps cfg dsLinks createOwnersGroup webFolder test -restoreDirectoryService :: HasCallStack => TestParams -> Int -> (TestCC -> (String, String) -> IO ()) -> IO () +restoreDirectoryService :: HasCallStack => TestParams -> Int -> (TestCC -> String -> IO ()) -> IO () restoreDirectoryService ps connCount test = do - dsLinks <- + dsLink <- withTestChat ps serviceDbPrefix $ \ds -> do ds .<## ("subscribed " <> show connCount <> " connections on server localhost") ds ##> "/sa" - dsLinks <- getContactLinks ds False + dsLink <- getContactLink ds False ds <## "auto_accept on" - pure dsLinks - withDirectory ps testCfg dsLinks test + pure dsLink + withDirectory ps testCfg dsLink test -withDirectory :: HasCallStack => TestParams -> ChatConfig -> (String, String) -> (TestCC -> (String, String) -> IO ()) -> IO () -withDirectory ps cfg dsLinks = withDirectoryOwnersGroup ps cfg dsLinks False Nothing +withDirectory :: HasCallStack => TestParams -> ChatConfig -> String -> (TestCC -> String -> IO ()) -> IO () +withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False Nothing -withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> (String, String) -> Bool -> Maybe FilePath -> (TestCC -> (String, String) -> IO ()) -> IO () -withDirectoryOwnersGroup ps cfg dsLinks createOwnersGroup webFolder test = do +withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> link -> Bool -> Maybe FilePath -> (TestCC -> link -> IO ()) -> IO () +withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] (if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing) webFolder runDirectory ps 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 dsLinks + test superUser dsLink runDirectory :: TestParams -> ChatConfig -> DirectoryOpts -> IO () -> IO () runDirectory ps cfg opts action = do @@ -2485,7 +2502,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 @@ -2524,7 +2541,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 @@ -2550,7 +2567,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 @@ -2567,7 +2584,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" @@ -2576,7 +2593,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 @@ -2645,7 +2662,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 ps $ \reg -> - withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> + withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do enableNamesRole bob @@ -2677,7 +2694,7 @@ testDirectoryChannelName ps = withSmpServerAndNames ps $ \reg -> -- the app renders simplexName as the directory's claim, so it has to reach the entry testDirectorySearchVerifiedName :: HasCallStack => TestParams -> IO () testDirectorySearchVerifiedName ps = withSmpServerAndNames ps $ \reg -> - withDirectoryServiceCfg ps testCfg $ \superUser (dsShortLink, dsLink) -> + withDirectoryServiceCfgLinks ps testCfg $ \superUser (dsShortLink, dsLink) -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do enableNamesRole bob @@ -2698,7 +2715,7 @@ testDirectorySearchVerifiedName ps = withSmpServerAndNames ps $ \reg -> -- registry re-pointed to a different link after the owner set the name: directory verification fails testDirectoryChannelNameNotVerified :: HasCallStack => TestParams -> IO () testDirectoryChannelNameNotVerified ps = withSmpServerAndNames ps $ \reg -> - withDirectoryServiceCfg ps testCfg $ \superUser (_, dsLink) -> + withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do enableNamesRole bob @@ -2730,7 +2747,7 @@ testDirectoryChannelNameNotVerified ps = withSmpServerAndNames ps $ \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 @@ -2742,7 +2759,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 @@ -2757,7 +2774,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 @@ -2793,7 +2810,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/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index b00d2e12b7..32460f36a4 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -21,7 +21,7 @@ import Data.Aeson (ToJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.List (intercalate, isPrefixOf, stripPrefix) +import Data.List (intercalate, isPrefixOf, isSuffixOf, stripPrefix) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) import qualified Data.Text as T @@ -29,10 +29,11 @@ import GHC.Conc (ThreadStatus (..), threadStatus) import Simplex.Chat.AppSettings (defaultAppSettings) import qualified Simplex.Chat.AppSettings as AS import Simplex.Chat.Call -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), PresetServers (..)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRServiceResponse), PresetServers (..)) +import Simplex.Chat.Core (sendChatCmdStr) import Simplex.Chat.Messages (ChatItemId) import Simplex.Chat.Options -import Simplex.Chat.Protocol (supportedChatVRange) +import Simplex.Chat.Protocol (maxServiceBodyLength, supportedChatVRange) import Simplex.Chat.Types (ContactId, VersionRangeChat, authErrDisableCount, sameVerificationCode, verificationCode, pattern VersionChat) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.RetryInterval @@ -133,6 +134,8 @@ chatDirectTests = do it "service request dropped when service processing is off" testServiceRequestDroppedWhenOff it "service request to a non-DR address fails fast" testServiceRequestNonDRAddress it "service request to an address upgraded by key rotation" testServiceRequestUpgradedAddress + it "service request over the size bound travels compressed" testServiceRequestCompressed + it "service request rejected without a reason times out" testServiceRequestRejectedNoReason it "create user with same servers" testCreateUserSameServers it "delete user" testDeleteUser it "delete user with chat tags" testDeleteUserChatTags @@ -2140,6 +2143,56 @@ testServiceRequestUpgradedAddress = alice <## ("service reply sent, connection id: " <> replyConnId) ) +testServiceRequestCompressed :: HasCallStack => TestParams -> IO () +testServiceRequestCompressed = + testChat2 aliceProfile bobProfile $ \alice bob -> do + alice ##> "/ad pq_ratchet=on" + (sLink, _) <- getContactLinks alice True + alice ##> "/_stop" + alice <## "chat stopped" + alice ##> "/_start main=on snd_files=on service_requests=on" + alice <### ["chat started", "subscribed 1 connections on server localhost"] + let request = "{\"ping\":\"" <> unwords (map show [1 .. 3000 :: Int]) <> "\"}" + length request `shouldSatisfy` (> maxServiceBodyLength) + concurrently_ + ( do + r <- sendChatCmdStr (chatController bob) ("/_service_request 1 " <> sLink <> " " <> request) + case r of + Right (CRServiceResponse _ responseData) -> J.encode responseData `shouldBe` "{\"pong\":2}" + _ -> expectationFailure $ "unexpected response: " <> show r + ) + ( do + reqId <- serviceRequestId alice + -- the test terminal queues only the last row of a line that wrapped + received <- getTermLine alice + received `shouldSatisfy` (`isSuffixOf` ("request: " <> request)) + alice ##> ("/_service_response 1 " <> reqId <> " {\"pong\":2}") + replyConnId <- serviceReplyConnId alice + alice <## ("service reply sent, connection id: " <> replyConnId) + ) + +-- without a reason nothing is sent back, so the requester waits out its timeout +testServiceRequestRejectedNoReason :: HasCallStack => TestParams -> IO () +testServiceRequestRejectedNoReason = + testChat2 aliceProfile bobProfile $ \alice bob -> do + alice ##> "/ad pq_ratchet=on" + (sLink, _) <- getContactLinks alice True + alice ##> "/_stop" + alice <## "chat stopped" + alice ##> "/_start main=on snd_files=on service_requests=on" + alice <### ["chat started", "subscribed 1 connections on server localhost"] + concurrently_ + ( do + bob ##> ("/_service_request 1 " <> sLink <> " timeout=5 {\"ping\":1}") + bob <## "smp agent error: AGENT {agentErr = A_SERVICE {serviceError = ASETimeout}}" + ) + ( do + reqId <- serviceRequestId alice + alice <## "request: {\"ping\":1}" + alice ##> ("/_reject_service_request 1 " <> reqId) + alice <## "ok" + ) + testMultipleUserAddresses :: HasCallStack => TestParams -> IO () testMultipleUserAddresses = testChat3 aliceProfile bobProfile cathProfile $