From 5e45fe1f0e26b0cd2b0ed5be91722067df13ddbd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 18 Aug 2026 16:35:37 +0100 Subject: [PATCH] directory: only create group links after approval (#7356) * directory: only create group links after approval * update test * update messages * diff * get group and link in one query * reduce database reads * better errors * typos * query plans --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- apps/simplex-directory-service/README.md | 23 +- .../src/Directory/Listing.hs | 27 +- .../src/Directory/Service.hs | 360 +++++++------ .../src/Directory/Store.hs | 54 +- docs/DIRECTORY.md | 15 +- plans/2026-08-04-directory-link-approval.md | 100 ++++ src/Simplex/Chat.hs | 1 + src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Library/Subscriber.hs | 3 +- tests/Bots/DirectoryTests.hs | 490 +++++++++--------- 10 files changed, 592 insertions(+), 482 deletions(-) create mode 100644 plans/2026-08-04-directory-link-approval.md diff --git a/apps/simplex-directory-service/README.md b/apps/simplex-directory-service/README.md index 5c397b6492..09df74abb0 100644 --- a/apps/simplex-directory-service/README.md +++ b/apps/simplex-directory-service/README.md @@ -143,11 +143,12 @@ The bot sends a welcome message automatically when you connect. ### 2. Registering a Group -Registration is a three-step process — see [DIRECTORY.md](../../docs/DIRECTORY.md) for full details: +Registration is a two-step process — see [DIRECTORY.md](../../docs/DIRECTORY.md) for full details: 1. Invite the directory bot to your group as `admin`. -2. Add the link the bot sends you to the group's welcome message. -3. Wait for admin approval (usually within a day, except holidays). +2. Wait for admin approval (usually within a day, except holidays). + +On approval the bot creates the join link, sends it to you, and recommends adding it to the group welcome message. Adding or removing this link in the welcome message keeps the group listed; other profile changes require re-approval. If a group with the same display name is already registered (but not yet listed or suspended), the bot asks you to confirm with `/confirm`. If the name is already listed or suspended in the directory, registration is blocked. @@ -277,33 +278,29 @@ Forward path, from invitation to being listed: └────────────┬─────────────┘ ▼ Proposed - │ bot joins the group and creates the link - ▼ - PendingUpdate - │ owner adds the link to the group welcome + │ bot joins the group ▼ PendingApproval - │ admin runs /approve + │ admin runs /approve; the bot creates the join link ▼ Active (listed; visible in search) ``` **Transitions out of Active:** -- → **PendingUpdate** — the directory bot link is removed from the welcome message. -- → **PendingApproval** — most other profile changes (see ** below); the `approval-id` shown to admins is bumped each time, so stale `/approve` commands are rejected. +- → **PendingApproval** — profile changes other than the bot link (see ** below); the `approval-id` shown to admins is bumped each time, so stale `/approve` commands are rejected. - → **Suspended** — an admin runs `/suspend`; `/resume` re-lists the group. - → **SuspendedBadRoles** — the directory bot loses its `admin` role, or the registering owner loses their `owner` role, in the group; automatically restored to **Active** once the roles are corrected. - → **Removed** — the owner runs `/delete`, the owner is removed from or leaves the group, the bot is removed from the group, or the group is deleted. The group can be re-registered afterwards. \* Only when the duplicate is registered but not yet listed or suspended. If the name is already listed or suspended, registration is blocked entirely. -\*\* Profile changes only trigger re-approval when fields other than the directory bot link are modified. If the only change is swapping the old bot link for the new one, or changing only whitespace in the description, the group stays Active. +\*\* Profile changes only trigger re-approval when fields other than the directory bot link are modified. Adding, removing, or replacing the bot link line in the welcome message, or changing only whitespace in the description, keeps the group Active. **State notes:** - **PendingConfirmation** — the bot was invited but a group with the same display name is already registered (in a pending state); the owner must run `/confirm` to proceed. - **Proposed** — the name is unique (or the duplicate was confirmed via `/confirm`); the bot is joining the group. -- **PendingUpdate** — the bot has joined the group and created the join link; the owner must add it to the group's welcome message. -- **PendingApproval** — submitted for admin review. The join link works even before approval. +- **PendingUpdate** — legacy state of registrations created before link-at-approval; any profile change moves such a group to PendingApproval. +- **PendingApproval** — submitted for admin review. The join link is created at first approval, so a new registration has no working link until approved. - **Active** — listed in the directory and visible in search results. diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs index d2df341545..dd7bbb509a 100644 --- a/apps/simplex-directory-service/src/Directory/Listing.hs +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -34,12 +35,30 @@ import Data.Time.Format.ISO8601 (iso8601Show) import Directory.Store import Simplex.Chat.Markdown import Simplex.Chat.Types +import Simplex.Chat.View (simplexChatContact) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) import System.Directory import System.FilePath +-- the line the directory recommends adding to the group welcome message +groupLinkLine :: Text -> Text -> Text +groupLinkLine name link = groupLinkLinePrefix name <> link + +groupLinkLinePrefix :: Text -> Text +groupLinkLinePrefix name = "Link to join the group " <> name <> ": " + +matchesGroupLink :: CreatedLinkContact -> FormattedText -> Bool +matchesGroupLink (CCLink cReq sLnk_) = \case + FormattedText (Just SimplexLink {simplexUri = ACL SCMContact cLink}) _ -> case cLink of + CLFull cReq' -> sameConnReqContact cReq' cReq + CLShort sLnk' -> maybe False (sameShortLinkContact sLnk') sLnk_ + _ -> False + +descriptionContainsLink :: CreatedLinkContact -> Text -> Bool +descriptionContainsLink gLink = maybe False (any (matchesGroupLink gLink)) . parseMaybeMarkdownList + directoryDataPath :: String directoryDataPath = "data" @@ -107,7 +126,13 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma let gtStr = case gt' of GTChannel -> "channel"; _ -> "group" linkLine = "Link to join the " <> gtStr <> " " <> displayName <> ": " <> decodeUtf8 (strEncode sLnk) in Just $ maybe linkLine (<> "\n\n" <> linkLine) description - Nothing -> description + Nothing -> case connLinkContact <$> gLink_ of + Just gLink@(CCLink cReq sLnk_) + | not (maybe False (descriptionContainsLink gLink) description) -> + let linkText = maybe (strEncode $ simplexChatContact cReq) strEncode sLnk_ + linkLine = groupLinkLine displayName $ decodeUtf8 linkText + in Just $ maybe linkLine (<> "\n\n" <> linkLine) description + _ -> description entry groupLink = let de = DirectoryEntry diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index a3af872ac3..079adeb730 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -25,13 +25,14 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Reader (runReaderT) import qualified Data.Attoparsec.Text as A import Data.Bifunctor (first) import Data.Either (fromRight) -import Data.List (find, intercalate) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList) +import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, maybeToList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -51,6 +52,7 @@ import Simplex.Chat.Bot import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller import Simplex.Chat.Core +import Simplex.Chat.Library.Internal (setGroupLinkData) import Simplex.Chat.Markdown (Format (..), FormattedText (..), SimplexLinkType (..), parseMaybeMarkdownList, viewName) import Simplex.Chat.Messages import Simplex.Chat.Options @@ -65,7 +67,8 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.View (groupSimplexDomain, serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), AgentErrorType (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), SimplexDomain, sameConnReqContact, sameShortLinkContact) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ACreatedConnLink (..), AgentErrorType (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), SimplexDomain) +import Simplex.Messaging.Client (NetworkRequestMode (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ErrorType (..)) @@ -78,13 +81,6 @@ import System.Exit (exitFailure) import System.Process (readProcess) import Text.Read (readMaybe) -data GroupProfileUpdate - = GPNoServiceLink - | GPServiceLinkAdded {linkNow :: Text} - | GPServiceLinkRemoved - | GPHasServiceLink {linkBefore :: Text, linkNow :: Text} - | GPServiceLinkError - data DuplicateGroup = DGUnique -- display name or full name is unique | DGRegistered -- the group with the same names is registered, additional confirmation is required @@ -166,7 +162,7 @@ directoryServiceCLI st opts = do acceptMember = Just $ acceptMemberHook opts env } raceAny_ $ - [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, + [ simplexChatCLI' terminalChatConfig {chatHooks, updateGroupLinksFromApp = True} (mkChatOpts opts) Nothing, processEvents env ] <> maybeToList (updateListingsThread_ opts env) @@ -242,7 +238,7 @@ directoryCommands = "Group settings" [ CBCCommand "role" "View new member role" idParam, CBCCommand "filter" "Anti-spam filter" idParam, - CBCCommand "link" "View and upgrade group link" idParam, + CBCCommand "link" "View group link" idParam, CBCCommand "delete" "Remove a group from directory" (Just ":''") ] ] @@ -258,7 +254,7 @@ directoryService st opts cfg = do postStartHook = Just $ directoryPostStartHook opts env, acceptMember = Just $ acceptMemberHook opts env } - simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \user cc -> + simplexChatCore cfg {chatHooks, updateGroupLinksFromApp = True} (mkChatOpts opts) $ \user cc -> raceAny_ $ [ forever $ do (_, resp) <- atomically . readTBQueue $ outputQ cc @@ -494,32 +490,17 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyOwner gr msg Right () -> do logGUpdateOwner st groupId $ groupMemberId' owner - notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" - sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case - Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> - setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do - notifyOwner - gr' - "Created the public link to join the group via this directory service that is always online.\n\n\ - \Please add it to the group welcome message.\n\ - \For example, add:" - notifyOwner gr' $ "Link to join the group " <> displayName <> ": " <> groupLinkText gLink - notifyOwner gr' $ recommendedSettingsNotice (userGroupRegId gr') - Left (ChatError e) -> case e of - CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin." - CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group." - CEGroupNotJoined _ -> notifyOwner gr $ unexpectedError "group not joined" - CEGroupMemberNotActive -> notifyOwner gr $ unexpectedError "service membership is not active" - _ -> notifyOwner gr $ unexpectedError "can't create group link" - _ -> notifyOwner gr $ unexpectedError "can't create group link" + setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do + notifyOwner gr' $ "Joined the group " <> displayName <> ". Registration is pending approval — it may take up to 48 hours." + notifyOwner gr' $ recommendedSettingsNotice (userGroupRegId gr') + verifyAndSendToApprove g gr' 1 deGroupUpdated :: GroupMember -> GroupInfo -> GroupInfo -> IO () deGroupUpdated m@GroupMember {memberProfile = LocalProfile {displayName = mName}} fromGroup toGroup = do logInfo $ "group updated " <> viewGroupName toGroup unless (sameProfile p p') $ do withGroupReg toGroup "group updated" $ \gr@GroupReg {groupRegStatus} -> do - let userGroupRef = userGroupReference gr toGroup - byMember = case memberContactId m of + let byMember = case memberContactId m of Just ctId | ctId `isOwner` gr -> "" -- group registration owner, not any group owner. _ -> " by " <> mName -- owner notification from directory will include the name. case publicGroup p' of @@ -530,26 +511,11 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Nothing -> case groupRegStatus of GRSPendingConfirmation -> pure () GRSProposed -> pure () - GRSPendingUpdate -> - groupProfileUpdate >>= \case - GPNoServiceLink -> - notifyOwner gr $ "The profile updated for " <> userGroupRef <> byMember <> ", but the group link is not added to the welcome message." - GPServiceLinkAdded _ -> groupLinkAdded gr byMember - GPServiceLinkRemoved -> - notifyOwner gr $ - "The group link of " <> userGroupRef <> " is removed from the welcome message" <> byMember <> ", please add it." - GPHasServiceLink {} -> groupLinkAdded gr byMember - GPServiceLinkError -> do - notifyOwner gr $ - ("Error: " <> serviceName <> " has no group link for " <> userGroupRef) - <> " after profile was updated" - <> byMember - <> ". Please report the error to the developers." - logError $ "Error: no group link for " <> userGroupRef - GRSPendingApproval n -> processProfileChange gr byMember False $ n + 1 - GRSActive -> processProfileChange gr byMember True 1 - GRSSuspended -> processProfileChange gr byMember False 1 - GRSSuspendedBadRoles -> processProfileChange gr byMember False 1 + GRSPendingUpdate -> sendForApproval byMember 1 + GRSPendingApproval n -> processProfileChange gr byMember $ n + 1 + GRSActive -> processProfileChange gr byMember 1 + GRSSuspended -> processProfileChange gr byMember 1 + GRSSuspendedBadRoles -> processProfileChange gr byMember 1 GRSRemoved -> pure () where GroupInfo {groupId, groupProfile = p} = fromGroup @@ -584,73 +550,46 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Nothing -> logError $ "no owner member set for " <> groupRef _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` toGroup) - groupLinkAdded gr byMember = - getDuplicateGroup toGroup >>= \case - Left e -> notifyOwner gr $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e - Right DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup - _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval gaId) $ \gr' -> do - notifyOwner gr' $ - ("Thank you! The group link for " <> userGroupReference gr' toGroup <> " is added to the welcome message" <> byMember) - <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." - checkRolesSendToApprove gr' gaId - where - gaId = 1 - processProfileChange gr byMember isActive n' = do - let userGroupRef = userGroupReference gr toGroup - groupRef = groupReference toGroup - groupProfileUpdate >>= \case - GPNoServiceLink -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do - notifyOwner gr' $ - ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") - <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." - GPServiceLinkRemoved -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do - notifyOwner gr' $ - ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) - <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." - notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." - GPServiceLinkAdded _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do - notifyOwner gr' $ - ("The group link is added to " <> userGroupRef <> byMember) - <> "!\nIt is hidden from the directory until approved." - notifyAdminUsers $ "The group link is added to " <> groupRef <> byMember <> "." - checkRolesSendToApprove gr n' - GPHasServiceLink {linkBefore, linkNow} - | isActive && onlyLinkChanged p p' -> do - notifyOwner gr $ - ("The group " <> userGroupRef <> " is updated" <> byMember) - <> "!\nThe group is listed in directory." - notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." - | otherwise -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do - notifyOwner gr' $ - ("The group " <> userGroupRef <> " is updated" <> byMember) - <> "!\nIt is hidden from the directory until approved." - notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> "." - checkRolesSendToApprove gr' n' - where - onlyLinkChanged - GroupProfile {displayName = dn, fullName = fn, shortDescr = sd, image = i, description = d, memberAdmission = ma} - GroupProfile {displayName = dn', fullName = fn', shortDescr = sd', image = i', description = d', memberAdmission = ma'} = - dn == dn' && fn == fn' && i == i' && sd == sd' && ma == ma' && (T.words . T.replace linkBefore "" <$> d) == (T.words . T.replace linkNow "" <$> d') - GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval." - groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) + sendForApproval byMember n' = + setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do + notifyOwner gr' $ + ("The group " <> userGroupReference gr' toGroup <> " is updated" <> byMember) + <> "!\nIt is hidden from the directory until approved." + notifyAdminUsers $ "The group " <> groupReference toGroup <> " is updated" <> byMember <> "." + checkRolesSendToApprove gr' n' + processProfileChange gr byMember n' = + withDB' "getGroupLink" cc (\db -> runExceptT $ getGroupLink db user toGroup) >>= \case + Left e -> linkReadError $ T.pack e + Right (Left SEGroupLinkNotFound {}) -> profileChange Nothing + Right (Left e) -> linkReadError $ tshow e + Right (Right gLink) -> profileChange $ Just gLink where - profileUpdate = \case - Right CRGroupLink {groupLink = GroupLink {connLinkContact = CCLink cr sl_}} -> - let linkBefore_ = profileGroupLinkText fromGroup - linkNow_ = profileGroupLinkText toGroup - profileGroupLinkText GroupInfo {groupProfile = GroupProfile {description = descr_}} = - maybe Nothing (fmap (\(FormattedText _ t) -> t) . find ftHasLink) $ parseMaybeMarkdownList =<< descr_ - ftHasLink = \case - FormattedText (Just SimplexLink {simplexUri = ACL SCMContact cLink}) _ -> case cLink of - CLFull cr' -> sameConnReqContact cr' cr - CLShort sl' -> maybe False (sameShortLinkContact sl') sl_ - _ -> False - in case (linkBefore_, linkNow_) of - (Just linkBefore, Just linkNow) -> GPHasServiceLink linkBefore linkNow - (Just _, Nothing) -> GPServiceLinkRemoved - (Nothing, Just linkNow) -> GPServiceLinkAdded linkNow - (Nothing, Nothing) -> GPNoServiceLink - _ -> GPServiceLinkError + linkReadError e = logError $ "Error reading group link for " <> groupReference toGroup <> ": " <> e + profileChange gLink_ + | not (linkOnlyChange gLink_) = sendForApproval byMember n' + | groupRegStatus gr == GRSActive = do + notifyOwner gr $ + ("The group " <> userGroupReference gr toGroup <> " is updated" <> byMember) + <> "!\nThe group is listed in directory." + notifyAdminUsers $ "The group " <> groupReference toGroup <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." + forM_ gLink_ $ \gLink -> + updateGroupLinkData cc user toGroup gLink >>= \case + Right _ -> pure () + Left e -> logError $ "Error updating group link data for " <> groupReference toGroup <> ": " <> tshow e + | otherwise = pure () + linkOnlyChange gLink_ = + dn == dn' && fn == fn' && i == i' && sd == sd' && ma == ma' && descrWords d == descrWords d' + where + GroupProfile {displayName = dn, fullName = fn, shortDescr = sd, image = i, description = d, memberAdmission = ma} = p + GroupProfile {displayName = dn', fullName = fn', shortDescr = sd', image = i', description = d', memberAdmission = ma'} = p' + -- drop the recommended link line (link token and prefix) so adding or removing it is not a content change + descrWords = maybe [] $ case gLink_ of + Just GroupLink {connLinkContact} -> + T.words . T.replace (groupLinkLinePrefix dn) "" . withoutLink connLinkContact + Nothing -> T.words + withoutLink gl descr = + maybe descr (T.concat . map ftText . filter (not . matchesGroupLink gl)) $ parseMaybeMarkdownList descr + ftText (FormattedText _ t) = t checkRolesSendToApprove gr gaId = do (badRolesMsg <$$> getGroupRolesStatus toGroup gr) >>= \case Left e -> notifyOwner gr $ "Error: getGroupRolesStatus. Please notify the developers.\n" <> T.pack e @@ -1095,11 +1034,9 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName \*To register a channel*, use _Share via chat_ to send its link to " <> serviceName <> " bot.\n\n\ - \*To register a group*:\n\ - \1️⃣ *Invite* " + \*To register a group*, *invite* " <> serviceName - <> " bot to your group as *admin* - it will create a link for new members to join.\n\ - \2️⃣ *Add* this link to the group's welcome message.\n\n\ + <> " bot to your group as *admin* - once the group is approved, it will create a link for new members to join.\n\n\ \Once your group or channel *approved*, it can be found here or at [simplex.chat/directory](https://simplex.chat/directory).\n\n\ \_We usually review within a day, except holidays_. [More details](https://simplex.chat/docs/directory.html#adding-groups-to-the-directory)." DCHelp DHSCommands -> @@ -1109,22 +1046,25 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName \/list - list the groups you registered.\n\ \`/role ` - view and set default member role for your group.\n\ \`/filter ` - view and set spam filter settings for group.\n\ - \`/link ` - view and upgrade group link.\n\ + \`/link ` - view group link.\n\ \`/delete :` - remove the group you submitted from directory, with _ID_ and _name_ as shown by /list command.\n\n\ \To search for groups, send the search text." - DCSearchGroup s ft -> - sendFoundListedGroups (STSearch s) Nothing notFound $ \gs n -> - let more = if n > length gs then ", sending top " <> tshow (length gs) else "" - in "Found " <> tshow n <> " group(s)" <> more <> "." + DCSearchGroup s ft -> case ft >>= groupLinkUri of + Just uri -> + getRegisteredGroupByLink uri >>= \case + Just (g, gr, ccLink) + | isAdmin -> sendGroupsInfo ct ciId True ([(g, gr)], 1) + | groupRegStatus gr == GRSActive -> sendFoundGroups "Found group:" [(g, gr, Just ccLink)] 0 + _ + | isAdmin -> sendReply "This link is not registered in the directory" + | otherwise -> sendReply linkNotFound + Nothing -> + sendFoundListedGroups (STSearch s) Nothing "No groups found" $ \gs n -> + let more = if n > length gs then ", sending top " <> tshow (length gs) else "" + in "Found " <> tshow n <> " group(s)" <> more <> "." where - notFound - | hasSimplexGroupLink ft = "No groups found.\nTo register a group or a channel, please use \"Share via chat\" feature." - | otherwise = "No groups found" - hasSimplexGroupLink = \case - Just fts -> any isGroupLink fts - Nothing -> False - isGroupLink (FormattedText (Just SimplexLink {linkType}) _) = linkType == XLGroup || linkType == XLChannel - isGroupLink _ = False + linkNotFound = "No groups found.\nTo register a group or a channel, please use \"Share via chat\" feature." + groupLinkUri fts = listToMaybe [uri | FormattedText (Just SimplexLink {linkType, simplexUri = uri}) _ <- fts, linkType == XLGroup || linkType == XLChannel] DCSearchNext -> atomically (TM.lookup (contactId' ct) searchRequests) >>= \case Just SearchRequest {searchType, searchTime, lastGroup} -> do @@ -1164,7 +1104,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName when (isJust pg_) $ leavePublicGroup g Left e -> sendReply $ "Error deleting " <> gt <> " " <> displayName <> ": " <> T.pack e DCMemberRole gId gName_ mRole_ -> - (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> + (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g gr -> ifPublicGroup g (sendReply "This command is not available for public groups.") $ do let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g case mRole_ of @@ -1176,14 +1116,17 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName initialRole n acceptMemberRole <> ("Send /'role " <> tshow gId <> " " <> textEncode anotherRole <> "' to change it.\n\n") <> onlyViaLink gLink - Left _ -> sendReply $ "Error: failed reading the initial member role for the group " <> n + Left _ -> sendReply $ roleError gr n $ "Error: failed reading the initial member role for the group " <> n Just mRole -> do setGroupLinkRole cc g mRole >>= \case Just gLink -> sendReply $ initialRole n mRole <> "\n" <> onlyViaLink gLink - Nothing -> sendReply $ "Error: the initial member role for the group " <> n <> " was NOT upgated." + Nothing -> sendReply $ roleError gr n $ "Error: the initial member role for the group " <> n <> " was NOT updated." where initialRole n mRole = "The initial member role for the group " <> n <> " is set to *" <> textEncode mRole <> "*\n" onlyViaLink gLink = "*Please note*: it applies only to members joining via this link: " <> groupLinkText gLink + roleError gr n err = case groupRegStatus gr of + GRSActive -> err + _ -> "The group link for " <> n <> " is created when the group is approved." DCGroupFilter gId gName_ acceptance_ -> (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> ifPublicGroup g (sendReply "This command is not available for public groups.") $ do @@ -1217,7 +1160,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Just PCAll -> "_enabled_" Just PCNoImage -> "_enabled for profiles without image_" DCShowUpgradeGroupLink gId gName_ -> - (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}, localDisplayName = gName} _ -> case pg_ of + (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}, localDisplayName = gName} gr -> case pg_ of Just pg@PublicGroupProfile {groupLink} -> sendReply $ "The link to join the " <> groupTypeStr' pg <> " " <> groupReference' gId gName <> ":\n" <> strEncodeTxt groupLink <> maybe "" (("\nSimpleX name: " <>) . simplexNameStr) (verifiedGroupDomain g) @@ -1225,7 +1168,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let groupRef = groupReference' gId gName withGroupLinkResult groupRef (sendChatCmd cc $ APIGetGroupLink groupId) $ \GroupLink {connLinkContact = gLink@(CCLink _ sLnk_), acceptMemberRole, shortLinkDataSet, shortLinkLargeDataSet = BoolDef slLargeDataSet} -> do - let shouldBeUpgraded = isNothing sLnk_ || not shortLinkDataSet || not slLargeDataSet + let shouldBeUpgraded = (isNothing sLnk_ || not shortLinkDataSet || not slLargeDataSet) && groupRegStatus gr == GRSActive sendReply $ T.unlines $ [ "The link to join the group " <> groupRef <> ":", @@ -1259,7 +1202,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName a >>= \case Right CRGroupLink {groupLink} -> cb groupLink Left (ChatErrorStore (SEGroupLinkNotFound _)) -> - sendReply $ "The group " <> groupRef <> " has no public link." + sendReply $ "The group " <> groupRef <> " has no public link.\nThe group link is created when the group is approved." Right r -> do ts <- getCurrentTime tz <- getCurrentTimeZone @@ -1289,38 +1232,55 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName sendReply notFound Right (gs, n) -> do let moreGroups = n - length gs - updateSearchRequest searchType $ last gs - sendFoundGroups (replyStr gs n) gs moreGroups + gs' = map (\(g, gr, gLink_) -> (g, gr, (\GroupLink {connLinkContact = cl} -> cl) <$> gLink_)) gs + updateSearchRequest searchType $ last gs' + sendFoundGroups (replyStr gs' n) gs' moreGroups Left e -> sendReply $ "Error: searchListedGroups. Please notify the developers.\n" <> T.pack e allGroupsReply sortName gs n = let more = if n > length gs then ", sending " <> sortName <> " " <> tshow (length gs) else "" in tshow n <> " group(s) listed" <> more <> "." - updateSearchRequest :: SearchType -> (GroupInfo, GroupReg) -> IO () - updateSearchRequest searchType (GroupInfo {groupId}, _) = do + updateSearchRequest :: SearchType -> (GroupInfo, GroupReg, Maybe CreatedLinkContact) -> IO () + updateSearchRequest searchType (GroupInfo {groupId}, _, _) = do searchTime <- getCurrentTime let search = SearchRequest {searchType, searchTime, lastGroup = groupId} atomically $ TM.insert (contactId' ct) search searchRequests + getRegisteredGroupByLink :: AConnectionLink -> IO (Maybe (GroupInfo, GroupReg, CreatedLinkContact)) + getRegisteredGroupByLink uri = + sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget uri)) PRMNever Nothing) >>= \case + Right (CRConnectionPlan _ (ACCL SCMContact ccLink) _ _ (CPGroupLink glp)) -> case glp of + GLPOwnLink g -> groupReg g ccLink + GLPKnown {groupInfo = g} -> groupReg g ccLink + GLPConnectingProhibit (Just g) -> groupReg g ccLink + _ -> pure Nothing + _ -> pure Nothing + where + groupReg :: GroupInfo -> CreatedLinkContact -> IO (Maybe (GroupInfo, GroupReg, CreatedLinkContact)) + groupReg g ccLink = fmap (\gr -> (g, gr, ccLink)) . eitherToMaybe <$> getGroupReg cc (groupId' g) sendFoundGroups reply gs moreGroups = void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs where msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0] replyMsg = (Just ciId, MCText reply) - foundGroup (g@GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_, memberAdmission}, groupSummary}, _) = + foundGroup (g@GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_, memberAdmission}, groupSummary}, _, cLink_) = let membersStr = "_" <> membersCountStr p groupSummary <> "_" showId = if isAdmin then tshow groupId <> ". " else "" - text = T.unlines $ [showId <> groupInfoText (simplexNameStr <$> verifiedGroupDomain g) p, membersStr] ++ knockingStr memberAdmission + text = T.unlines $ [showId <> groupInfoText (simplexNameStr <$> verifiedGroupDomain g) p] <> foundGroupLinkLine p cLink_ <> [membersStr] <> knockingStr memberAdmission in (Nothing, maybe (MCText text) (\image -> MCImage {text, image}) image_) moreMsg = (Nothing, MCText $ "Send /next for " <> tshow moreGroups <> " more result(s).") - + -- link line for a non-public group in search results, unless its welcome message already contains it + foundGroupLinkLine GroupProfile {displayName = n, description, publicGroup} cLink_ = case (publicGroup, cLink_) of + (Nothing, Just gLink) + | not (maybe False (descriptionContainsLink gLink) description) -> [groupLinkLine n (groupLinkText gLink)] + _ -> [] deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () deAdminCommand ct ciId cmd | knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of DCApproveGroup {groupId, displayName = n, groupApprovalId, promote} -> - withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId, promoted} -> + withGroupRegLink sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId, promoted} curLink_ -> case groupRegStatus gr of GRSPendingApproval gaId | gaId == groupApprovalId -> do - let GroupInfo {groupProfile = GroupProfile {publicGroup = pg_}} = g + let GroupInfo {groupProfile = GroupProfile {publicGroup = pg_, description = descr_}} = g isPublicGroup_ = isJust pg_ gt = maybe "group" groupTypeStr' pg_ getDuplicateGroup g >>= \case @@ -1333,28 +1293,37 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let grPromoted' | promoted || knownCt `elem` superUsers = fromMaybe promoted promote | otherwise = False - setGroupStatusPromo sendReply st env cc gr GRSActive grPromoted' $ do - let approved = "The " <> gt <> " " <> userGroupReference' gr n <> " is approved" - let commands - | isPublicGroup_ = "" - | otherwise = - "\n\nSupported commands:\n" - <> ("/'filter " <> tshow ugrId <> "' - to configure anti-spam filter.\n") - <> ("/'role " <> tshow ugrId <> "' - to set default member role.\n") - <> ("/'link " <> tshow ugrId <> "' - to view/upgrade group link.") - notifyOwner gr $ - (approved <> " and listed in directory - please moderate it!\n") - <> "_Please note_: if you change the " <> gt <> " profile it will be hidden from directory until it is re-approved." - <> commands - invited <- - forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do - inviteToOwnersGroup og gr $ \case - Right () -> do - owner <- groupOwnerInfo groupRef $ dbContactId gr - pure $ "Invited " <> owner <> " to owners' group " <> viewName ogName - Left err -> pure err - sendReply $ T.toTitle gt <> " approved" <> (if grPromoted' then " (promoted)" else "") <> "!" <> maybe "" ("\n" <>) invited - notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct) <> maybe "" ("\n" <>) invited + gLink_ <- if isPublicGroup_ then pure (Right Nothing) else approvedGroupLink g curLink_ + case gLink_ of + Left e -> sendReply e + Right gLink' -> + setGroupStatusPromo sendReply st env cc gr GRSActive grPromoted' $ do + let approved = "The " <> gt <> " " <> userGroupReference' gr n <> " is approved" + addLink = maybe False (\l -> not $ maybe False (descriptionContainsLink l) descr_) gLink' + commands + | isPublicGroup_ = "" + | otherwise = + "\n\nSupported commands:\n" + <> ("/'filter " <> tshow ugrId <> "' - to configure anti-spam filter.\n") + <> ("/'role " <> tshow ugrId <> "' - to set default member role.\n") + <> ("/'link " <> tshow ugrId <> "' - to view group link.") + notifyOwner gr $ + (approved <> " and listed in directory - please moderate it!\n") + <> ( if addLink + then "To help people join, copy the next message with the group link and add it to the end of the group welcome message. The group will remain listed. Any other change to the group profile hides it from the directory until it is re-approved." + else "_Please note_: if you change the " <> gt <> " profile it will be hidden from directory until it is re-approved." + ) + <> commands + when addLink $ forM_ gLink' $ \l -> notifyOwner gr $ groupLinkLine n (groupLinkText l) + invited <- + forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do + inviteToOwnersGroup og gr $ \case + Right () -> do + owner <- groupOwnerInfo groupRef $ dbContactId gr + pure $ "Invited " <> owner <> " to owners' group " <> viewName ogName + Left err -> pure err + sendReply $ T.toTitle gt <> " approved" <> (if grPromoted' then " (promoted)" else "") <> "!" <> maybe "" ("\n" <>) invited + notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct) <> maybe "" ("\n" <>) invited Right GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin Right GRSContactNotOwner -> replyNotApproved "user is not an owner." Right GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin @@ -1363,9 +1332,24 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName replyNotApproved reason = sendReply $ "Group is not approved: " <> reason serviceNotAdmin = serviceName <> " is not an admin." | otherwise -> sendReply "Incorrect approval code" - _ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval." + status -> sendReply $ "Error: the group " <> groupRef <> " status is " <> groupRegStatusText status <> ", it is not pending approval." where groupRef = groupReference' groupId n + approvedGroupLink g = \case + Just gLink -> + updateGroupLinkData cc user g gLink >>= \case + Right GroupLink {connLinkContact} -> pure $ Right $ Just connLinkContact + Left e -> pure $ Left $ "Error updating group link data: " <> tshow e + Nothing -> + sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case + Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact}} -> pure $ Right $ Just connLinkContact + Left (ChatError e) -> pure $ Left $ case e of + CEGroupUserRole {} -> "Failed creating group link, as service is no longer an admin." + CEGroupMemberUserRemoved -> "Failed creating group link, as service is removed from the group." + CEGroupNotJoined _ -> unexpectedError "group not joined" + CEGroupMemberNotActive -> unexpectedError "service membership is not active" + _ -> unexpectedError "can't create group link" + _ -> pure $ Left $ unexpectedError "can't create group link" DCRejectGroup _gaId _gName -> pure () DCSuspendGroup groupId gName -> do let groupRef = groupReference' groupId gName @@ -1376,7 +1360,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyOwner gr' $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" notifyOtherSuperUsers $ suspended <> " by " <> viewName (localDisplayName' ct) - _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended." + status -> sendReply $ "The group " <> groupRef <> " status is " <> groupRegStatusText status <> ", it can't be suspended." DCResumeGroup groupId gName -> do let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr -> @@ -1386,7 +1370,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyOwner gr' $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct) - _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." + status -> sendReply $ "The group " <> groupRef <> " status is " <> groupRegStatusText status <> ", it can't be resumed." DCListLastGroups count -> listLastGroups cc user count >>= \case Left e -> sendReply $ "Error reading groups: " <> T.pack e @@ -1473,18 +1457,25 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName mkSendReply :: Contact -> ChatItemId -> Text -> IO () mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText + withGroupRegLink :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> Maybe GroupLink -> IO ()) -> IO () + withGroupRegLink sendReply gId = withGroupRegLink_ sendReply gId . Just + + withGroupRegLink_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> Maybe GroupLink -> IO ()) -> IO () + withGroupRegLink_ sendReply gId gName_ action = + getGroupAndRegLink cc user gId >>= \case + Left e -> sendReply $ "Group " <> tshow gId <> " error (getGroup): " <> T.pack e + Right (g@GroupInfo {groupProfile = GroupProfile {displayName}}, gr, gLink_) + | maybe False (displayName ==) gName_ -> + action g gr gLink_ + | otherwise -> + sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName + withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () withGroupAndReg sendReply gId = withGroupAndReg_ sendReply gId . Just withGroupAndReg_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () withGroupAndReg_ sendReply gId gName_ action = - getGroupAndReg cc user gId >>= \case - Left e -> sendReply $ "Group " <> tshow gId <> " error (getGroup): " <> T.pack e - Right (g@GroupInfo {groupProfile = GroupProfile {displayName}}, gr) - | maybe False (displayName ==) gName_ -> - action g gr - | otherwise -> - sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName + withGroupRegLink_ sendReply gId gName_ $ \g gr _ -> action g gr getOwnersInfo :: [(GroupInfo, GroupReg)] -> IO [((GroupInfo, GroupReg), Maybe (Either String Contact))] getOwnersInfo gs = @@ -1567,6 +1558,9 @@ getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Either String GroupL getGroupLink' cc user gInfo = withDB "getGroupLink" cc $ \db -> withExceptT groupDBError $ getGroupLink db user gInfo +updateGroupLinkData :: ChatController -> User -> GroupInfo -> GroupLink -> IO (Either ChatError GroupLink) +updateGroupLinkData cc user gInfo gLink = runReaderT (runExceptT $ setGroupLinkData NRMBackground user gInfo gLink) cc + setGroupLinkRole :: ChatController -> GroupInfo -> GroupMemberRole -> IO (Maybe CreatedLinkContact) setGroupLinkRole cc GroupInfo {groupId} mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole groupId mRole) where diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index e3465e64b1..133daacaf3 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -37,7 +37,7 @@ module Directory.Store getAllGroupRegs_, getDuplicateGroupRegs, getGroupReg, - getGroupAndReg, + getGroupAndRegLink, listLastGroups, listPendingGroups, getAllListedGroups, @@ -93,7 +93,8 @@ import Simplex.Chat.Store import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Shared (groupInfoQueryFields, groupInfoQueryFrom) import Simplex.Chat.Types -import Simplex.Messaging.Agent.Protocol (SimplexDomain) +import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Messaging.Agent.Protocol (CreatedConnLink (..), SimplexDomain) import Simplex.Messaging.Agent.Store.DB (BoolInt (..), fromTextField_) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Encoding.String @@ -330,11 +331,11 @@ getGroupReg_ db gId = |] (Only gId) -getGroupAndReg :: ChatController -> User -> GroupId -> IO (Either String (GroupInfo, GroupReg)) -getGroupAndReg cc user@User {userId, userContactId} gId = - withDB "getGroupAndReg" cc $ \db -> do +getGroupAndRegLink :: ChatController -> User -> GroupId -> IO (Either String (GroupInfo, GroupReg, Maybe GroupLink)) +getGroupAndRegLink cc user@User {userId, userContactId} gId = + withDB "getGroupAndRegLink" cc $ \db -> do currentTs <- liftIO getCurrentTime - ExceptT $ firstRow (toGroupInfoReg currentTs (storeCxt cc) user) ("group " ++ show gId ++ " not found") $ + ExceptT $ firstRow (toGroupInfoRegLink currentTs (storeCxt cc) user) ("group " ++ show gId ++ " not found") $ DB.query db (groupReqQuery <> " AND g.group_id = ?") (userId, userContactId, gId) getUserGroupReg :: ChatController -> User -> ContactId -> UserGroupRegId -> IO (Either String (GroupInfo, GroupReg)) @@ -357,12 +358,10 @@ getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllList getAllListedGroups_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)] getAllListedGroups_ db cxt user@User {userId, userContactId} = do currentTs <- getCurrentTime - DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive) - >>= mapM (withGroupLink . toGroupInfoReg currentTs cxt user) - where - withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g) + map (toGroupInfoRegLink currentTs cxt user) + <$> DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive) -searchListedGroups :: ChatController -> User -> SearchType -> Maybe GroupId -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int)) +searchListedGroups :: ChatController -> User -> SearchType -> Maybe GroupId -> Int -> IO (Either String ([(GroupInfo, GroupReg, Maybe GroupLink)], Int)) searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pageSize = withDB' "searchListedGroups" cc $ \db -> do currentTs <- getCurrentTime @@ -409,7 +408,7 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? " orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC " where - groups currentTs = (map (toGroupInfoReg currentTs (storeCxt cc) user) <$>) + groups currentTs = (map (toGroupInfoRegLink currentTs (storeCxt cc) user) <$>) count = maybeFirstRow' 0 fromOnly 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 " @@ -456,9 +455,12 @@ listPendingGroups cc user@User {userId, userContactId} count = n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs WHERE group_reg_status LIKE 'pending_approval%'" pure (gs, n) -toGroupInfoReg :: UTCTime -> StoreCxt -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg) -toGroupInfoReg currentTs cxt User {userContactId} (groupRow :. grRow) = - (toGroupInfo currentTs cxt userContactId [] groupRow, rowToGroupReg grRow) +toGroupInfoReg :: UTCTime -> StoreCxt -> User -> (GroupInfoRow :. GroupRegRow :. GroupLinkRow) -> (GroupInfo, GroupReg) +toGroupInfoReg currentTs cxt user row = let (g, gr, _) = toGroupInfoRegLink currentTs cxt user row in (g, gr) + +toGroupInfoRegLink :: UTCTime -> StoreCxt -> User -> (GroupInfoRow :. GroupRegRow :. GroupLinkRow) -> (GroupInfo, GroupReg, Maybe GroupLink) +toGroupInfoRegLink currentTs cxt User {userContactId} (groupRow :. grRow :. linkRow) = + (toGroupInfo currentTs cxt userContactId [] groupRow, rowToGroupReg grRow, toMaybeGroupLink linkRow) type GroupRegRow = (GroupId, UserGroupRegId, ContactId, Maybe GroupMemberId, GroupRegStatus, BoolInt, UTCTime) @@ -466,10 +468,30 @@ rowToGroupReg :: GroupRegRow -> GroupReg rowToGroupReg (dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, BI promoted, createdAt) = GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt} +type GroupLinkRow = (Maybe Int64, Maybe ConnReqContact, Maybe ShortLinkContact, Maybe BoolInt, Maybe BoolInt, Maybe GroupLinkId, Maybe GroupMemberRole) + +toMaybeGroupLink :: GroupLinkRow -> Maybe GroupLink +toMaybeGroupLink (Just userContactLinkId, Just cReq, shortLink, slDataSet, slLarge, Just groupLinkId, mRole_) = + Just + GroupLink + { userContactLinkId, + connLinkContact = CCLink cReq shortLink, + shortLinkDataSet = boolInt slDataSet, + shortLinkLargeDataSet = BoolDef $ boolInt slLarge, + groupLinkId, + acceptMemberRole = fromMaybe GRMember mRole_ + } + where + boolInt = maybe False (\(BI b) -> b) +toMaybeGroupLink _ = Nothing + +-- group with its registration and its join link (user_contact_links) in one query groupReqQuery :: Query -groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupInfoQueryFrom <> groupRegFromCond +groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupLinkFields <> groupInfoQueryFrom <> groupLinkJoin <> groupRegFromCond where groupRegFields = ", r.group_id, r.user_group_reg_id, r.contact_id, r.owner_member_id, r.group_reg_status, r.group_promoted, r.created_at " + groupLinkFields = ", uc.user_contact_link_id, uc.conn_req_contact, uc.short_link_contact, uc.short_link_data_set, uc.short_link_large_data_set, uc.group_link_id, uc.group_link_member_role " + groupLinkJoin = " LEFT JOIN user_contact_links uc ON uc.group_id = g.group_id AND uc.user_id = g.user_id " groupRegFromCond = " JOIN sx_directory_group_regs r ON r.group_id = g.group_id WHERE g.user_id = ? AND mu.contact_id = ? " data DirectoryLogRecord diff --git a/docs/DIRECTORY.md b/docs/DIRECTORY.md index 50e7771a1a..9a1e26b9f7 100644 --- a/docs/DIRECTORY.md +++ b/docs/DIRECTORY.md @@ -22,32 +22,27 @@ Please note that your search queries can be kept by the bot as the conversation To add a group you must be its owner. Once you connect to the directory service and send `/help`, the service will guide you through the process. -1. Invite SimpleX Service Directory to the group as `admin` member. You can also set the role to `admin` after inviting the directory service. +1. Invite SimpleX Service Directory to the group as `admin` member. You can also set the role to `admin` after inviting the directory service. The member who invited the directory service will be the owner of the group record in the directory service. The directory service needs to be `admin` to provide a good user experience of joining the group, as it will create a new link to join the group, which is expected to be online 99% of the time. -2. Add the link sent to you by the directory service to the group welcome message. This has to be done by the same group member who invited the directory service to the group. This member will be the owner of the group record in the directory service. - -3. Once the link is added, the group will need to be approved by the directory service admins. This link is functional even before the group is approved, and you can continue using this link even if the group is not approved. +2. The group will need to be approved by the directory service admins. The directory service creates the link to join the group when the group is approved, and sends it to you. The group is usually approved within 24 hours. Please see below which groups can be added. -Once the group is approved, it will appear in search results. +Once the group is approved, it will appear in search results together with the link to join it. We recommend adding this link to the group welcome message - adding or removing it does not require a new approval. You can list all the groups you submitted by sending `/list` to the directory service. ### How to remove the group from the directory -Changing the group profile in any way (e.g., changing the group name, welcome message, or removing the link to join the group from the welcome message) will remove the group from the search results until the group is approved again by the directory service admins. +Changing the group profile (e.g., the group name, image, or the text of the welcome message) will remove the group from the search results until the group is approved again by the directory service admins. Adding or removing the directory link in the welcome message does not require a new approval. If it is undesirable that the service cannot be found in search during this time, please coordinate the time of this change with the directory service admins for quick approval. Changing the role of the directory service will temporarily remove the group from the search results, and unless you changed the role to the `owner`, it will also permanently disrupt the members that were in the process of connecting to other members via the directory service. -To remove the group from the directory: - -1. Remove the group link created by the directory service from the welcome message. This will not disrupt the members from joining the group, even via this link, but will remove the group from the search results. -2. After some time (we recommend 3-4 days) remove the directory service from the group - it will stop receiving the messages and the group will be permanently removed from the search results. +To remove the group from the directory, send `/delete :` to the directory service, with the ID and name shown by `/list`. You can also remove the directory service from the group - the group will be permanently removed from the search results. Removing the group does not prevent you from registering the group again in the future. diff --git a/plans/2026-08-04-directory-link-approval.md b/plans/2026-08-04-directory-link-approval.md new file mode 100644 index 0000000000..6c92ca5bd9 --- /dev/null +++ b/plans/2026-08-04-directory-link-approval.md @@ -0,0 +1,100 @@ +# Directory: group link creation at approval + +Date: 2026-08-04 + +## Goal + +- The directory creates the group join link at first approval. +- The directory issues every link data update; the automatic refresh in core is disabled by config. +- The welcome message link requirement is replaced by a post-approval recommendation. +- A link sent to the directory is resolved to its registered group. + +Existing functions are amended; the diff is kept minimal, in code and in tests. + +## 1. Core (simplex-chat library) + +1.1. `ChatConfig`: add `updateGroupLinksFromApp :: Bool`, default `False`. The directory service sets `True` in `directoryService` and `directoryServiceCLI`. + +1.2. `xGrpInfo` (Subscriber.hs ~3750): condition before the fork: + +```haskell +ChatConfig {updateGroupLinksFromApp} <- asks config +unless (useRelays' g'' || updateGroupLinksFromApp) $ + void $ forkIO $ void $ setGroupLinkData' NRMBackground user g'' +``` + +`setGroupLinkData'` stays unchanged. The call in `runUpdateGroupProfile` (Commands.hs ~4043) stays unconditional. + +1.3. Link data sync from the directory: a Service.hs helper reads the link with `getGroupLink` and runs `setGroupLinkData NRMBackground user gInfo gLink` (Internal.hs ~1461, exported) via `runReaderT (runExceptT …) cc`; the `GroupInfo` argument supplies the profile. + +## 2. Registration flow (Service.hs) + +2.1. `deServiceJoinedGroup`: after `setGroupRegOwner` — set `GRSPendingApproval 1`, notify the owner ("Joined the group X. Registration is pending approval — it may take up to 48 hours."), send `recommendedSettingsNotice`, call `verifyAndSendToApprove`. The `APICreateGroupLink` call and the `GRSPendingUpdate` transition are removed. This mirrors the channel flow in `deMemberUpdated`. + +2.2. `DCApproveGroup`, after the duplicate and roles checks, before `setGroupStatusPromo`: + +- link record present (legacy registration or re-approval): the §1.3 sync with the `GroupInfo` from `getGroupAndReg`; +- link record absent: `APICreateGroupLink groupId GRMember`; on failure reply with the error and keep the status. + +Owner notification: approved, the link, "We recommend adding this link to the group welcome message." + +## 3. Profile update handling (`deGroupUpdated`, non-public groups) + +3.1. `GroupProfileUpdate` and `groupProfileUpdate` are replaced by one check — link-only change: fields other than description equal, descriptions equal after removal of the service link and the recommended phrase "Link to join the group :", with `T.words` normalization. The link is read with `APIGetGroupLink`; on `SEGroupLinkNotFound` the comparison runs without link removal; on other failures — log, no action (as today). The description-contains-link check (`profileGroupLinkText`, Service.hs ~641) moves to a helper shared with §6. + +3.2. Transitions. `n'` — n+1 when the status is `GRSPendingApproval n`, 1 otherwise. "Send to approve" — `checkRolesSendToApprove` as today. + +| status | change | status' | actions | +|---|---|---|---| +| GRSActive | link-only | GRSActive | notify owner; §1.3 sync with the event `toGroup` | +| GRSPendingApproval n | link-only | unchanged | — (the sent approval code stays valid) | +| GRSSuspended, GRSSuspendedBadRoles | link-only | unchanged | — | +| GRSPendingUpdate (legacy data only) | any | GRSPendingApproval 1 | notify owner; send to approve | +| any of the above | other change | GRSPendingApproval n' | notify owner and admins; send to approve | + +The `GRSPendingUpdate` branch of the `deGroupUpdated` dispatch (~533) is removed; the status is routed through `processProfileChange`. Link removal while active keeps the group listed; `GRSPendingUpdate` is unreachable for new registrations. Channel handling (`publicGroupProfileChange`) stays unchanged. + +## 4. Command replies (Service.hs) + +- `DCMemberRole`, group without a link: "The group link is created when the group is approved." +- `DCShowUpgradeGroupLink`: the `SEGroupLinkNotFound` reply mentions approval; the `APIAddGroupShortLink` upgrade branch requires `GRSActive`. +- `DCResumeGroup`, `DCSuspendGroup`, `DCApproveGroup` fallback replies include `groupRegStatusText`. +- `DCHelp DHSRegistration`: the welcome message step is replaced by approval; link inclusion is described as a post-approval recommendation. + +## 5. Search by link + +5.1. Detection: in `DCSearchGroup`, when the formatted text holds a `SimplexLink` of type `XLGroup` or `XLChannel`, the first such `simplexUri`, wrapped with `aConnectTarget`, is the lookup target. + +5.2. Lookup: `APIConnectPlan userId (Just target) PRMNever Nothing`: + +- `CPGroupLink (GLPOwnLink g)`, `CPGroupLink (GLPKnown {groupInfo})` → `getGroupReg` by group id; +- other plans, `CENotResolvedLocally` → unknown link. + +5.3. Replies: + +- user, `GRSActive` → the found-group message (single entry, existing format); +- user, other status or unknown link → the current not-found reply; +- admin, registered → group info with `groupRegStatusText` and owner, as in `sendGroupsInfo` admin format; +- admin, unknown link → "This link is not registered in the directory." + +5.4. Card path: `deChatLinkReceived` branches without a valid owner signature run the §5.2 lookup on `connLink`; `GLPKnown` → reply per §5.3; otherwise the current replies. + +## 6. Link in listings and search results + +6.1. Bot search results: `sendFoundGroups` appends the join-link line for non-public groups when the description omits the link; result rows are extended with the group link via `getGroupLink`. + +6.2. `groupDirectoryEntry` (Listing.hs): the join-link line, currently appended for public groups, is appended for non-public groups too when the description omits the link. + +## 7. Legacy registrations + +Registrations created before deployment keep their links. Their updates follow §3.2. Their approval syncs the link data (§2.2, first branch). + +## 8. Tests (DirectoryTests.hs) + +- Amend `submitGroup`, `groupAccepted`, `completeRegistrationId`, `updateProfileWithLink`, `notifySuperUser`, `approveRegistrationId` to the new sequence — submit → pending approval → approve → link in the approval notification — changing only the affected expected lines. +- New cases: link-only description change keeps the listing and syncs link data; content change requires re-approval; link-only change while pending keeps the approval code valid; profile change while suspended; legacy waiting-for-link registration moves to approval on profile change; `/resume` reply with status; `/role` and `/link` replies before approval; search by link as user and as admin; card from a non-owner for a listed group. + +## 9. Docs + +- `apps/simplex-directory-service/README.md`: registration steps and the state machine section. +- Bot `/help` text is covered by §4. diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b795ba9b9c..b672dc23a1 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -136,6 +136,7 @@ defaultChatConfig = relayRequestExpiry = (10, nominalDay), deviceNameForRemote = "", remoteCompression = True, + updateGroupLinksFromApp = False, chatHooks = defaultChatHooks } diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 6a80f51a1e..d570129ef3 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -172,6 +172,7 @@ data ChatConfig = ChatConfig highlyAvailable :: Bool, deviceNameForRemote :: Text, remoteCompression :: Bool, + updateGroupLinksFromApp :: Bool, chatHooks :: ChatHooks } diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index a65bed75a0..00c7a8cdf3 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -3747,7 +3747,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' -- in channels, link data is updated by the owner making the change in runUpdateGroupProfile; -- other owners receiving the update do not refresh the same link - unless (useRelays' g'') $ + ChatConfig {updateGroupLinksFromApp} <- asks config + unless (useRelays' g'' || updateGroupLinksFromApp) $ void $ forkIO $ void $ setGroupLinkData' NRMBackground user g'' Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' -- relay advertises its web capability now that the owner's version is known (bumped by saveGroupRcvMsg) diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 15f713cd1c..2807efbf02 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -12,7 +12,7 @@ import ChatTests.Groups (memberJoinChannel, prepareChannel1Relay) import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (finally) -import Control.Monad (forM_, when) +import Control.Monad (forM_, void, when) import qualified Data.Aeson as J import qualified Data.Text as T import Directory.Captcha @@ -44,6 +44,7 @@ directoryServiceTests = do it "admin should delete group registration" testDeleteGroupAdmin it "should change initial member role" testSetRole it "should join found group via link" testJoinGroup + it "should find registered group by link" testSearchByLink it "should support group names with spaces" testGroupNameWithSpaces it "should return more groups in search, all and recent groups" testSearchGroups it "should invite to owners' group if specified" testInviteToOwnersGroup @@ -63,7 +64,7 @@ directoryServiceTests = do it "the registration owner" testRegOwnerChangedProfile it "another owner" testAnotherOwnerChangedProfile it "another owner not connected to directory" testNotConnectedOwnerChangedProfile - describe "should require profile update if group link is removed by " $ do + describe "should NOT require re-approval if group link is added or removed by" $ do it "the registration owner" testRegOwnerRemovedLink it "another owner" testAnotherOwnerRemovedLink it "another owner not connected to directory" testNotConnectedOwnerRemovedLink @@ -71,7 +72,7 @@ directoryServiceTests = do it "should ask for confirmation if a duplicate group is submitted" testDuplicateAskConfirmation it "should prohibit registration if a duplicate group is listed" testDuplicateProhibitRegistration it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation - it "should prohibit when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated + it "should allow to rename and approve a duplicate registration" testDuplicateProhibitWhenUpdated it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval describe "list and promote groups" $ do it "should list and promote user's groups" $ testListUserGroups True @@ -173,34 +174,18 @@ testDirectoryService ps = bob <## "invitation to join the group #PSA sent to 'SimpleX Directory'" bob <# "'SimpleX Directory'> You must grant directory service admin role to register the group" bob ##> "/mr PSA 'SimpleX Directory' admin" - -- putStrLn "*** discover service joins group and creates the link for profile" + -- putStrLn "*** discover service joins group and sends the registration for approval" bob <## "#PSA: you changed the role of 'SimpleX Directory' to admin" bob <# "'SimpleX Directory'> Joining the group PSA…" bob <## "#PSA: 'SimpleX Directory' joined the group" - bob <# "'SimpleX Directory'> Joined the group PSA, creating the link…" - bob <# "'SimpleX Directory'> Created the public link to join the group via this directory service that is always online." - bob <## "" - bob <## "Please add it to the group welcome message." - bob <## "For example, add:" - welcomeWithLink <- dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine bob + bob <# "'SimpleX Directory'> Joined the group PSA. Registration is pending approval — it may take up to 48 hours." bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." bob <## "Captcha verification is enabled. Use /'filter 1' to change it." - -- putStrLn "*** update profile without link" + notifySuperUser_ superUser bob "PSA" "Privacy, Security & Anonymity" Nothing 1 1 + -- putStrLn "*** update profile before approval - new approval code" updateGroupProfile bob "Welcome!" - bob <# "'SimpleX Directory'> The profile updated for ID 1 (PSA), but the group link is not added to the welcome message." - (superUser Thank you! The group link for ID 1 (PSA) is added to the welcome message." - bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - approvalRequested superUser welcomeWithLink (1 :: Int) - -- putStrLn "*** update profile so that it still has link" - let welcomeWithLink' = "Welcome! " <> welcomeWithLink - updateGroupProfile bob welcomeWithLink' - bob <# "'SimpleX Directory'> The group ID 1 (PSA) is updated!" - bob <## "It is hidden from the directory until approved." - superUser <# "'SimpleX Directory'> The group ID 1 (PSA) is updated." - approvalRequested superUser welcomeWithLink' (2 :: Int) + groupUpdatedHidden superUser bob "PSA" "" + notifySuperUser_ superUser bob "PSA" "Privacy, Security & Anonymity" (Just "Welcome!") 1 2 -- putStrLn "*** try approving with the old registration code" bob #> "@'SimpleX Directory' /approve 1:PSA 1" bob <# "'SimpleX Directory'> > /approve 1:PSA 1" @@ -208,44 +193,36 @@ testDirectoryService ps = superUser #> "@'SimpleX Directory' /approve 1:PSA 1" superUser <# "'SimpleX Directory'> > /approve 1:PSA 1" superUser <## " Incorrect approval code" - -- putStrLn "*** update profile so that it has no link" - updateGroupProfile bob "Welcome!" - bob <# "'SimpleX Directory'> The group link for ID 1 (PSA) is removed from the welcome message." - bob <## "" - bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." - superUser <# "'SimpleX Directory'> The group link is removed from ID 1 (PSA), de-listed." - superUser #> "@'SimpleX Directory' /approve 1:PSA 2" - superUser <# "'SimpleX Directory'> > /approve 1:PSA 2" - superUser <## " Error: the group ID 1 (PSA) is not pending approval." - -- putStrLn "*** update profile so that it has link again" - updateGroupProfile bob welcomeWithLink' - bob <# "'SimpleX Directory'> Thank you! The group link for ID 1 (PSA) is added to the welcome message." - bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - approvalRequested superUser welcomeWithLink' (1 :: Int) superUser #> "@'SimpleX Directory' /pending" superUser <# "'SimpleX Directory'> > /pending" superUser <## " 1 registered group(s)" superUser <# "'SimpleX Directory'> 1. PSA (Privacy, Security & Anonymity)" superUser <## "Welcome message:" - superUser <##. "Welcome! Link to join the group PSA: " + superUser <## "Welcome!" superUser <## "Owner: bob" superUser <## "2 members" superUser <## "Status: pending admin approval" superUser <## "/'role 1', /'filter 1'" - superUser #> "@'SimpleX Directory' /approve 1:PSA 1" - superUser <# "'SimpleX Directory'> > /approve 1:PSA 1" - superUser <## " Group approved!" - bob <# "'SimpleX Directory'> The group ID 1 (PSA) is approved and listed in directory - please moderate it!" - bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." - bob <## "" - bob <## "Supported commands:" - bob <## "/'filter 1' - to configure anti-spam filter." - bob <## "/'role 1' - to set default member role." - bob <## "/'link 1' - to view/upgrade group link." + welcomeWithLink <- approveRegistration_ superUser bob "PSA" 1 1 2 + -- putStrLn "*** add the link to the welcome message - the group remains listed" + let welcomeWithLink' = "Welcome! " <> welcomeWithLink + updateGroupProfile bob welcomeWithLink' + groupUpdatedListed superUser bob "PSA" "" search bob "privacy" welcomeWithLink' search bob "security" welcomeWithLink' cath `connectVia` dsLink search cath "privacy" welcomeWithLink' + -- putStrLn "*** remove the link from the welcome message - the group remains listed" + updateGroupProfile bob "Welcome!" + groupUpdatedListed superUser bob "PSA" "" + bob #> "@'SimpleX Directory' privacy" + bob <# "'SimpleX Directory'> > privacy" + bob <## " Found 1 group(s)." + bob <# "'SimpleX Directory'> PSA (Privacy, Security & Anonymity)" + bob <## "Welcome message:" + bob <## "Welcome!" + bob <##. "Link to join the group PSA: " + bob <## "2 members" bob #> "@'SimpleX Directory' /exec /contacts" bob <# "'SimpleX Directory'> > /exec /contacts" bob <## " You are not allowed to use this command" @@ -267,15 +244,6 @@ testDirectoryService ps = u ##> ("/set welcome #PSA " <> welcome) u <## "welcome message changed to:" u <## welcome - approvalRequested su welcome grId = do - su <# "'SimpleX Directory'> bob submitted the group ID 1:" - su <## "PSA (Privacy, Security & Anonymity)" - su <## "Welcome message:" - su <## welcome - su <## "2 members" - su <## "" - su <## "To approve send:" - su <# ("'SimpleX Directory'> /approve 1:PSA " <> show grId) testSuspendResume :: HasCallStack => TestParams -> IO () testSuspendResume ps = @@ -301,23 +269,18 @@ testSuspendResume ps = superUser <## " The link to join the group ID 1 (privacy):" superUser <##. "https://localhost/g#" superUser <## "New member role: member" - -- get and change the link to the equivalent - should not ask to re-approve + -- add the link to the welcome message - the group remains listed bob #> "@'SimpleX Directory' /link 1" bob <# "'SimpleX Directory'> > /link 1" bob <## " The link to join the group ID 1 (privacy):" gLink <- getTermLine bob gLink `shouldStartWith` "https://localhost/g#" bob <## "New member role: member" - bob ##> "/show welcome #privacy" - bob <## "Welcome message:" - bob <## ("Link to join the group privacy: " <> gLink) - bob ##> ("/set welcome #privacy Link to join the group privacy: " <> gLink <> "?same_link=true") - bob <## "welcome message changed to:" - bob <## ("Link to join the group privacy: " <> gLink <> "?same_link=true") - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated!" - bob <## "The group is listed in directory." - superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated - only link or whitespace changes." - superUser <## "The group remained listed in directory." + setWelcomeMessage bob [] ("Link to join the group privacy: " <> gLink) + groupUpdatedListed superUser bob "privacy" "" + -- change the link to the equivalent - should not ask to re-approve + setWelcomeMessage bob [] ("Link to join the group privacy: " <> gLink <> "?same_link=true") + groupUpdatedListed superUser bob "privacy" "" #if !defined(dbPostgres) -- upgrade link -- make it upgradeable first @@ -421,7 +384,6 @@ testSetRole ps = cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://localhost/g#" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -445,9 +407,8 @@ testJoinGroup ps = cath <# "'SimpleX Directory'> > privacy" cath <## " Found 1 group(s)." cath <# "'SimpleX Directory'> privacy (Privacy)" - cath <## "Welcome message:" - welcomeMsg <- getTermLine cath - let groupLink = dropStrPrefix "Link to join the group privacy: " welcomeMsg + linkLine <- getTermLine cath + let groupLink = dropStrPrefix "Link to join the group privacy: " linkLine cath <## "2 members" cath ##> ("/c " <> groupLink) cath <## "connection request sent!" @@ -463,7 +424,6 @@ testJoinGroup ps = cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -478,7 +438,6 @@ testJoinGroup ps = do dan <## "#privacy: joining the group..." dan <## "#privacy: you joined the group" - dan <# ("#privacy bob> " <> welcomeMsg) dan <### [ "#privacy: member 'SimpleX Directory' is connected", "#privacy: member cath (Catherine) is connected" @@ -488,6 +447,47 @@ testJoinGroup ps = cath <## "#privacy: new member dan is connected" ] +testSearchByLink :: HasCallStack => TestParams -> IO () +testSearchByLink ps = + withDirectoryService ps $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> do + bob `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 + welcomeWithLink <- approveRegistration superUser bob "privacy" 1 + let link = dropStrPrefix "Link to join the group privacy: " welcomeWithLink + -- user finds the listed group by link + bob #> ("@'SimpleX Directory' " <> link) + bob <# ("'SimpleX Directory'> > " <> link) + bob <## " Found group:" + bob <# "'SimpleX Directory'> privacy (Privacy)" + bob <##. "Link to join the group privacy: " + bob <## "2 members" + -- admin receives the group with status + superUser #> ("@'SimpleX Directory' " <> link) + superUser <# ("'SimpleX Directory'> > " <> link) + superUser <## " 1 registered group(s)" + memberGroupListing superUser bob 1 "privacy" "Privacy" 2 "active" + -- content change hides the group from user search, admin still finds it by link + setWelcomeMessage bob [] "Welcome!" + groupUpdatedHidden superUser bob "privacy" "" + notifySuperUser_ superUser bob "privacy" "Privacy" (Just "Welcome!") 1 1 + bob #> ("@'SimpleX Directory' " <> link) + bob <# ("'SimpleX Directory'> > " <> link) + bob <## " No groups found." + bob <## "To register a group or a channel, please use \"Share via chat\" feature." + superUser #> ("@'SimpleX Directory' " <> link) + superUser <# ("'SimpleX Directory'> > " <> link) + superUser <## " 1 registered group(s)" + superUser <# "'SimpleX Directory'> 1. privacy (Privacy)" + superUser <## "Welcome message:" + superUser <## "Welcome!" + superUser <## "Owner: bob" + superUser <## "2 members" + superUser <## "Status: pending admin approval" + superUser <## "/'role 1', /'filter 1'" + testGroupNameWithSpaces :: HasCallStack => TestParams -> IO () testGroupNameWithSpaces ps = withDirectoryService ps $ \superUser dsLink -> @@ -588,7 +588,6 @@ testSearchGroups ps = receivedGroup :: TestCC -> Int -> Int -> IO () receivedGroup u ix count = do u <#. ("'SimpleX Directory'> " <> groups !! ix) - u <## "Welcome message:" u <##. "Link to join the group " u <## (show count <> " members") @@ -818,19 +817,22 @@ testNotSentApprovalBadRoles ps = bob `connectVia` dsLink cath `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" 1 + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 bob ##> "/mr privacy 'SimpleX Directory' member" bob <## "#privacy: you changed the role of 'SimpleX Directory' to member" - updateProfileWithLink bob "privacy" welcomeWithLink 1 + bob ##> "/gp privacy privacy Privacy!" + bob <## "description changed to: Privacy!" + groupUpdatedHidden superUser bob "privacy" "" bob <# "'SimpleX Directory'> You must grant directory service admin role to register the group" bob ##> "/mr privacy 'SimpleX Directory' admin" bob <## "#privacy: you changed the role of 'SimpleX Directory' to admin" bob <# "'SimpleX Directory'> SimpleX Directory role in the group ID 1 (privacy) is changed to admin." bob <## "" bob <## "The group is submitted for approval." - notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + notifySuperUser_ superUser bob "privacy" "Privacy!" Nothing 1 2 groupNotFound cath "privacy" - approveRegistration superUser bob "privacy" 1 + void $ approveRegistration_ superUser bob "privacy" 1 1 2 groupFound cath "privacy" testNotApprovedBadRoles :: HasCallStack => TestParams -> IO () @@ -841,9 +843,8 @@ testNotApprovedBadRoles ps = bob `connectVia` dsLink cath `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" 1 - updateProfileWithLink bob "privacy" welcomeWithLink 1 - notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 bob ##> "/mr privacy 'SimpleX Directory' member" bob <## "#privacy: you changed the role of 'SimpleX Directory' to member" let approve = "/approve 1:privacy 1" @@ -856,8 +857,8 @@ testNotApprovedBadRoles ps = bob <# "'SimpleX Directory'> SimpleX Directory role in the group ID 1 (privacy) is changed to admin." bob <## "" bob <## "The group is submitted for approval." - notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 - approveRegistration superUser bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 + void $ approveRegistration superUser bob "privacy" 1 groupFound cath "privacy" testRegOwnerChangedProfile :: HasCallStack => TestParams -> IO () @@ -933,34 +934,21 @@ testRegOwnerRemovedLink ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - bob ##> "/show welcome #privacy" - bob <## "Welcome message:" - welcomeWithLink <- getTermLine bob - bob ##> "/set welcome #privacy Welcome!" - bob <## "welcome message changed to:" - bob <## "Welcome!" - bob <# "'SimpleX Directory'> The group link for ID 1 (privacy) is removed from the welcome message." - bob <## "" - bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." - cath <## "bob updated group #privacy:" - cath <## "welcome message changed to:" - cath <## "Welcome!" - superUser <# "'SimpleX Directory'> The group link is removed from ID 1 (privacy), de-listed." + -- setting the welcome message requires re-approval + setWelcomeMessage bob [cath] "Welcome!" + groupUpdatedHidden superUser bob "privacy" "" + reapproveGroup_ 3 superUser bob (Just "Welcome!") + -- adding the link keeps the group listed + gLink <- getGroupLinkFromBot bob + setWelcomeMessage bob [cath] ("Welcome! Link to join the group privacy: " <> gLink) + groupUpdatedListed superUser bob "privacy" "" + -- removing the link keeps the group listed + setWelcomeMessage bob [cath] "Welcome!" + groupUpdatedListed superUser bob "privacy" "" cath `connectVia` dsLink cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" cath <## "use @'SimpleX Directory' to send messages" - groupNotFound cath "privacy" - let withChangedLink = T.unpack $ T.replace "contact#/?v=2-7&" "contact#/?v=3-7&" $ T.pack welcomeWithLink - bob ##> ("/set welcome #privacy " <> withChangedLink) - bob <## "welcome message changed to:" - bob <## withChangedLink - bob <# "'SimpleX Directory'> Thank you! The group link for ID 1 (privacy) is added to the welcome message." - bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - cath <## "bob updated group #privacy:" - cath <## "welcome message changed to:" - cath <## withChangedLink - reapproveGroup 3 superUser bob - groupFoundN 3 cath "privacy" + groupFoundWelcome 3 cath "privacy" "Welcome!" testAnotherOwnerRemovedLink :: HasCallStack => TestParams -> IO () testAnotherOwnerRemovedLink ps = @@ -973,30 +961,18 @@ testAnotherOwnerRemovedLink ps = cath `connectVia` dsLink cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" cath <## "use @'SimpleX Directory' to send messages" - bob ##> "/show welcome #privacy" - bob <## "Welcome message:" - welcomeWithLink <- getTermLine bob - cath ##> "/set welcome #privacy Welcome!" - cath <## "welcome message changed to:" - cath <## "Welcome!" - bob <## "cath updated group #privacy:" - bob <## "welcome message changed to:" - bob <## "Welcome!" - bob <# "'SimpleX Directory'> The group link for ID 1 (privacy) is removed from the welcome message by cath." - bob <## "" - bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." - superUser <# "'SimpleX Directory'> The group link is removed from ID 1 (privacy), de-listed." - groupNotFound cath "privacy" - cath ##> ("/set welcome #privacy " <> welcomeWithLink) - cath <## "welcome message changed to:" - cath <## welcomeWithLink - bob <## "cath updated group #privacy:" - bob <## "welcome message changed to:" - bob <## welcomeWithLink - bob <# "'SimpleX Directory'> Thank you! The group link for ID 1 (privacy) is added to the welcome message by cath." - bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - reapproveGroup 3 superUser bob - groupFoundN 3 cath "privacy" + -- setting the welcome message requires re-approval + setWelcomeMessage cath [bob] "Welcome!" + groupUpdatedHidden superUser bob "privacy" " by cath" + reapproveGroup_ 3 superUser bob (Just "Welcome!") + -- another owner adds the link - the group remains listed + gLink <- getGroupLinkFromBot bob + setWelcomeMessage cath [bob] ("Welcome! Link to join the group privacy: " <> gLink) + groupUpdatedListed superUser bob "privacy" " by cath" + -- another owner removes the link - the group remains listed + setWelcomeMessage cath [bob] "Welcome!" + groupUpdatedListed superUser bob "privacy" " by cath" + groupFoundWelcome 3 cath "privacy" "Welcome!" testNotConnectedOwnerRemovedLink :: HasCallStack => TestParams -> IO () testNotConnectedOwnerRemovedLink ps = @@ -1008,39 +984,19 @@ testNotConnectedOwnerRemovedLink ps = dan `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - bob ##> "/show welcome #privacy" - bob <## "Welcome message:" - welcomeWithLink <- getTermLine bob - cath ##> "/set welcome #privacy Welcome!" - cath <## "welcome message changed to:" - cath <## "Welcome!" - bob <## "cath updated group #privacy:" - bob <## "welcome message changed to:" - bob <## "Welcome!" - bob <# "'SimpleX Directory'> The group link for ID 1 (privacy) is removed from the welcome message by cath." - bob <## "" - bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." - superUser <# "'SimpleX Directory'> The group link is removed from ID 1 (privacy), de-listed." + -- setting the welcome message requires re-approval + setWelcomeMessage cath [bob] "Welcome!" + groupUpdatedHidden superUser bob "privacy" " by cath" groupNotFound dan "privacy" - cath ##> ("/set welcome #privacy " <> welcomeWithLink) - cath <## "welcome message changed to:" - cath <## welcomeWithLink - bob <## "cath updated group #privacy:" - bob <## "welcome message changed to:" - bob <## welcomeWithLink - -- bob <# "'SimpleX Directory'> The group link is added by another group member, your registration will not be processed." - -- bob <## "" - -- bob <## "Please update the group profile yourself." - -- bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!") - -- bob <## "welcome message changed to:" - -- bob <## (welcomeWithLink <> " - welcome!") - bob <# "'SimpleX Directory'> Thank you! The group link for ID 1 (privacy) is added to the welcome message by cath." - bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - -- cath <## "bob updated group #privacy:" - -- cath <## "welcome message changed to:" - -- cath <## (welcomeWithLink <> " - welcome!") - reapproveGroup 3 superUser bob - groupFoundN 3 dan "privacy" + reapproveGroup_ 3 superUser bob (Just "Welcome!") + -- the not connected owner adds the link - the group remains listed + gLink <- getGroupLinkFromBot bob + setWelcomeMessage cath [bob] ("Welcome! Link to join the group privacy: " <> gLink) + groupUpdatedListed superUser bob "privacy" " by cath" + -- the not connected owner removes the link - the group remains listed + setWelcomeMessage cath [bob] "Welcome!" + groupUpdatedListed superUser bob "privacy" " by cath" + groupFoundWelcome 3 dan "privacy" "Welcome!" testDuplicateAskConfirmation :: HasCallStack => TestParams -> IO () testDuplicateAskConfirmation ps = @@ -1049,16 +1005,17 @@ testDuplicateAskConfirmation ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - _ <- groupAccepted bob "privacy" 1 + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 cath `connectVia` dsLink submitGroup cath "privacy" "Privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already submitted to the directory." cath <## "To confirm the registration, please send:" cath <# "'SimpleX Directory'> /confirm 1:privacy" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink <- groupAccepted cath "privacy" 1 + groupAccepted cath "privacy" 1 groupNotFound bob "privacy" - completeRegistrationId superUser cath "privacy" "Privacy" welcomeWithLink 2 1 + void $ completeRegistrationId superUser cath "privacy" "Privacy" 2 1 groupFound bob "privacy" testDuplicateProhibitRegistration :: HasCallStack => TestParams -> IO () @@ -1080,14 +1037,14 @@ testDuplicateProhibitConfirmation ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" 1 + groupAccepted bob "privacy" 1 cath `connectVia` dsLink submitGroup cath "privacy" "Privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already submitted to the directory." cath <## "To confirm the registration, please send:" cath <# "'SimpleX Directory'> /confirm 1:privacy" groupNotFound cath "privacy" - completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + void $ completeRegistration superUser bob "privacy" "Privacy" 1 groupFound cath "privacy" cath #> "@'SimpleX Directory' /confirm 1:privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already listed in the directory, please choose another name." @@ -1099,27 +1056,27 @@ testDuplicateProhibitWhenUpdated ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" 1 + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 cath `connectVia` dsLink submitGroup cath "privacy" "Privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already submitted to the directory." cath <## "To confirm the registration, please send:" cath <# "'SimpleX Directory'> /confirm 1:privacy" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink' <- groupAccepted cath "privacy" 1 + groupAccepted cath "privacy" 1 + notifySuperUser superUser cath "privacy" "Privacy" 2 groupNotFound cath "privacy" - completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + void $ approveRegistration superUser bob "privacy" 1 groupFound cath "privacy" - cath ##> ("/set welcome privacy " <> welcomeWithLink') - cath <## "welcome message changed to:" - cath <## welcomeWithLink' - cath <# "'SimpleX Directory'> The group privacy (Privacy) is already listed in the directory, please choose another name." + -- the duplicate registration is renamed and approved cath ##> "/gp privacy security Security" cath <## "changed to #security (Security)" - cath <# "'SimpleX Directory'> Thank you! The group link for ID 1 (security) is added to the welcome message." - cath <## "You will be notified once the group is added to the directory - it may take up to 48 hours." - notifySuperUser superUser cath "security" "Security" welcomeWithLink' 2 - approveRegistrationId superUser cath "security" 2 1 + cath <# "'SimpleX Directory'> The group ID 1 (security) is updated!" + cath <## "It is hidden from the directory until approved." + superUser <# "'SimpleX Directory'> The group ID 2 (security) is updated." + notifySuperUser_ superUser cath "security" "Security" Nothing 2 2 + void $ approveRegistration_ superUser cath "security" 2 1 2 groupFound bob "security" groupFound cath "security" @@ -1130,18 +1087,18 @@ testDuplicateProhibitApproval ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" 1 + groupAccepted bob "privacy" 1 + notifySuperUser superUser bob "privacy" "Privacy" 1 cath `connectVia` dsLink submitGroup cath "privacy" "Privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already submitted to the directory." cath <## "To confirm the registration, please send:" cath <# "'SimpleX Directory'> /confirm 1:privacy" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink' <- groupAccepted cath "privacy" 1 - updateProfileWithLink cath "privacy" welcomeWithLink' 1 - notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2 + groupAccepted cath "privacy" 1 + notifySuperUser superUser cath "privacy" "Privacy" 2 groupNotFound cath "privacy" - completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + void $ approveRegistration superUser bob "privacy" 1 groupFound cath "privacy" -- fails at approval, as already listed let approve = "/approve 2:privacy 1" @@ -1187,15 +1144,11 @@ testListUserGroups promote ps = checkListings ["privacy", "security"] ["privacy"] bob ##> "/gp privacy privacy" bob <## "description removed" - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated!" - bob <## "It is hidden from the directory until approved." cath <## "bob updated group #privacy:" cath <## "description removed" - superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated." + groupUpdatedHidden superUser bob "privacy" "" superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" superUser <## "privacy" - superUser <## "Welcome message:" - superUser <##. "Link to join the group privacy: https://localhost/g#" superUser <## "3 members" superUser <## "" superUser <## "To approve send:" @@ -1204,13 +1157,7 @@ testListUserGroups promote ps = superUser #> "@'SimpleX Directory' /approve 1:privacy 1" superUser <# "'SimpleX Directory'> > /approve 1:privacy 1" superUser <## " Group approved (promoted)!" - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is approved and listed in directory - please moderate it!" - bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." - bob <## "" - bob <## "Supported commands:" - bob <## "/'filter 1' - to configure anti-spam filter." - bob <## "/'role 1' - to set default member role." - bob <## "/'link 1' - to view/upgrade group link." + void $ groupApprovedNotification bob "privacy" 1 checkListings ["privacy", "security"] ["privacy"] checkListings :: HasCallStack => [T.Text] -> [T.Text] -> IO () @@ -1260,7 +1207,6 @@ testAlwaysCaptcha ps = cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1315,7 +1261,6 @@ testCaptchaByDefault ps = cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1342,7 +1287,6 @@ testCapthaScreening ps = cath <## " Incorrect text, please try again." captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath sendCaptcha cath captcha - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1366,7 +1310,6 @@ testCapthaScreening ps = -- message from cath that left pastMember <- dropStrPrefix "#privacy: 'SimpleX Directory' forwarded a message from an unknown member, creating unknown member record " <$> getTermLine cath cath <# ("#privacy " <> pastMember <> "> hello [>>]") - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath_1 (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath_1 is connected" @@ -1444,7 +1387,6 @@ testVoiceCaptchaScreening ps@TestParams {tmpPath} = do cath <## " Audio captcha is already enabled." -- send correct captcha sendCaptcha cath captcha - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1554,7 +1496,6 @@ testVoiceCaptchaVoiceDisabled ps@TestParams {tmpPath} = do cath <#. "#privacy (support) 'SimpleX Directory'> sends file " cath <##. "use /fr 1" sendCaptcha cath captcha - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1611,7 +1552,6 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do cath <## " Voice captcha is not available - please update SimpleX Chat to v6.5+ or use text captcha." -- text captcha still works sendCaptcha cath captcha - cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://" cath <## "#privacy: member bob (Bob) is connected" bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)" bob <## "#privacy: new member cath is connected" @@ -1711,8 +1651,6 @@ memberGroupListing su owner = groupListing_ su (Just owner) groupListing_ :: HasCallStack => TestCC -> Maybe TestCC -> Int -> String -> String -> Int -> String -> IO () groupListing_ su owner_ gId n fn count status = do su <# ("'SimpleX Directory'> " <> show gId <> ". " <> n <> " (" <> fn <> ")") - su <## "Welcome message:" - su <##. ("Link to join the group " <> n <> ": ") forM_ owner_ $ \owner -> do ownerName <- userName owner su <## ("Owner: " <> ownerName) @@ -1721,11 +1659,15 @@ groupListing_ su owner_ gId n fn count status = do su <## ("/'role " <> show gId <> "', /'filter " <> show gId <> "'") reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO () -reapproveGroup count superUser bob = do +reapproveGroup count superUser bob = reapproveGroup_ count superUser bob Nothing + +reapproveGroup_ :: HasCallStack => Int -> TestCC -> TestCC -> Maybe String -> IO () +reapproveGroup_ count superUser bob welcome_ = do superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" superUser <##. "privacy (" - superUser <## "Welcome message:" - superUser <##. "Link to join the group privacy: " + forM_ welcome_ $ \welcome -> do + superUser <## "Welcome message:" + superUser <## welcome superUser <## (show count <> " members") superUser <## "" superUser <## "To approve send:" @@ -1733,13 +1675,7 @@ reapproveGroup count superUser bob = do superUser #> "@'SimpleX Directory' /approve 1:privacy 1" superUser <# "'SimpleX Directory'> > /approve 1:privacy 1" superUser <## " Group approved!" - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is approved and listed in directory - please moderate it!" - bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." - bob <## "" - bob <## "Supported commands:" - bob <## "/'filter 1' - to configure anti-spam filter." - bob <## "/'role 1' - to set default member role." - bob <## "/'link 1' - to view/upgrade group link." + void $ groupApprovedNotification bob "privacy" 1 addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO () addCathAsOwner bob cath = do @@ -1813,8 +1749,8 @@ registerGroup su u n fn = registerGroupId su u n fn 1 1 registerGroupId :: TestCC -> TestCC -> String -> String -> Int -> Int -> IO () registerGroupId su u n fn gId ugId = do submitGroup u n fn - welcomeWithLink <- groupAccepted u n ugId - completeRegistrationId su u n fn welcomeWithLink gId ugId + groupAccepted u n ugId + void $ completeRegistrationId su u n fn gId ugId submitGroup :: TestCC -> String -> String -> IO () submitGroup u n fn = do @@ -1824,70 +1760,91 @@ submitGroup u n fn = do u ##> ("/a " <> viewName n <> " 'SimpleX Directory' admin") u <## ("invitation to join the group #" <> viewName n <> " sent to 'SimpleX Directory'") -groupAccepted :: TestCC -> String -> Int -> IO String +groupAccepted :: TestCC -> String -> Int -> IO () groupAccepted u n ugId = do u <### [ WithTime ("'SimpleX Directory'> Joining the group " <> n <> "…"), ConsoleString ("#" <> viewName n <> ": 'SimpleX Directory' joined the group") ] - u <# ("'SimpleX Directory'> Joined the group " <> n <> ", creating the link…") - u <# "'SimpleX Directory'> Created the public link to join the group via this directory service that is always online." - u <## "" - u <## "Please add it to the group welcome message." - u <## "For example, add:" - welcomeWithLink <- dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine u + u <# ("'SimpleX Directory'> Joined the group " <> n <> ". Registration is pending approval — it may take up to 48 hours.") u <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." u <## ("Captcha verification is enabled. Use /'filter " <> show ugId <> "' to change it.") - pure welcomeWithLink -completeRegistration :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () -completeRegistration su u n fn welcomeWithLink gId = - completeRegistrationId su u n fn welcomeWithLink gId gId +completeRegistration :: TestCC -> TestCC -> String -> String -> Int -> IO String +completeRegistration su u n fn gId = + completeRegistrationId su u n fn gId gId -completeRegistrationId :: TestCC -> TestCC -> String -> String -> String -> Int -> Int -> IO () -completeRegistrationId su u n fn welcomeWithLink gId ugId = do - updateProfileWithLink u n welcomeWithLink ugId - notifySuperUser su u n fn welcomeWithLink gId +completeRegistrationId :: TestCC -> TestCC -> String -> String -> Int -> Int -> IO String +completeRegistrationId su u n fn gId ugId = do + notifySuperUser su u n fn gId approveRegistrationId su u n gId ugId -updateProfileWithLink :: TestCC -> String -> String -> Int -> IO () -updateProfileWithLink u n welcomeWithLink ugId = do - u ##> ("/set welcome " <> viewName n <> " " <> welcomeWithLink) - u <## "welcome message changed to:" - u <## welcomeWithLink - u <# ("'SimpleX Directory'> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.") - u <## "You will be notified once the group is added to the directory - it may take up to 48 hours." +notifySuperUser :: TestCC -> TestCC -> String -> String -> Int -> IO () +notifySuperUser su u n fn gId = notifySuperUser_ su u n fn Nothing gId 1 -notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () -notifySuperUser su u n fn welcomeWithLink gId = do +notifySuperUser_ :: TestCC -> TestCC -> String -> String -> Maybe String -> Int -> Int -> IO () +notifySuperUser_ su u n fn welcome_ gId gaId = do uName <- userName u su <# ("'SimpleX Directory'> " <> uName <> " submitted the group ID " <> show gId <> ":") su <## (n <> if null fn then "" else " (" <> fn <> ")") - su <## "Welcome message:" - su <## welcomeWithLink + forM_ welcome_ $ \welcome -> do + su <## "Welcome message:" + su <## welcome su .<## "members" su <## "" su <## "To approve send:" - let approve = "/approve " <> show gId <> ":" <> viewName n <> " 1" + let approve = "/approve " <> show gId <> ":" <> viewName n <> " " <> show gaId su <# ("'SimpleX Directory'> " <> approve) -approveRegistration :: TestCC -> TestCC -> String -> Int -> IO () +approveRegistration :: TestCC -> TestCC -> String -> Int -> IO String approveRegistration su u n gId = approveRegistrationId su u n gId gId -approveRegistrationId :: TestCC -> TestCC -> String -> Int -> Int -> IO () -approveRegistrationId su u n gId ugId = do - let approve = "/approve " <> show gId <> ":" <> viewName n <> " 1" +approveRegistrationId :: TestCC -> TestCC -> String -> Int -> Int -> IO String +approveRegistrationId su u n gId ugId = approveRegistration_ su u n gId ugId 1 + +approveRegistration_ :: TestCC -> TestCC -> String -> Int -> Int -> Int -> IO String +approveRegistration_ su u n gId ugId gaId = do + let approve = "/approve " <> show gId <> ":" <> viewName n <> " " <> show gaId su #> ("@'SimpleX Directory' " <> approve) su <# ("'SimpleX Directory'> > " <> approve) su <## " Group approved!" + groupApprovedNotification u n ugId + +groupApprovedNotification :: TestCC -> String -> Int -> IO String +groupApprovedNotification u n ugId = do u <# ("'SimpleX Directory'> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory - please moderate it!") - u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." + u <## "To help people join, copy the next message with the group link and add it to the end of the group welcome message. The group will remain listed. Any other change to the group profile hides it from the directory until it is re-approved." u <## "" u <## "Supported commands:" u <## ("/'filter " <> show ugId <> "' - to configure anti-spam filter.") u <## ("/'role " <> show ugId <> "' - to set default member role.") - u <## ("/'link " <> show ugId <> "' - to view/upgrade group link.") + u <## ("/'link " <> show ugId <> "' - to view group link.") + dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine u + +groupUpdatedHidden :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () +groupUpdatedHidden superUser u n byMember = do + u <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> "!") + u <## "It is hidden from the directory until approved." + superUser <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> ".") + +groupUpdatedListed :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () +groupUpdatedListed superUser u n byMember = do + u <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> "!") + u <## "The group is listed in directory." + superUser <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> " - only link or whitespace changes.") + superUser <## "The group remained listed in directory." + +setWelcomeMessage :: HasCallStack => TestCC -> [TestCC] -> String -> IO () +setWelcomeMessage u others welcome = do + uName <- userName u + u ##> ("/set welcome #privacy " <> welcome) + u <## "welcome message changed to:" + u <## welcome + forM_ others $ \m -> do + m <## (uName <> " updated group #privacy:") + m <## "welcome message changed to:" + m <## welcome connectVia :: TestCC -> String -> IO () u `connectVia` dsLink = do @@ -1906,10 +1863,8 @@ joinGroup :: String -> TestCC -> TestCC -> IO () joinGroup gName member host = do let gn = "#" <> gName memberName <- userName member - hostName <- userName host member ##> ("/j " <> gName) member <## (gn <> ": you joined the group") - member <#. (gn <> " " <> hostName <> "> Link to join the group " <> gName <> ": ") host <## (gn <> ": " <> memberName <> " joined the group") leaveGroup :: String -> TestCC -> IO () @@ -1945,10 +1900,29 @@ groupFoundN_ suffix shownId_ count u name = do u <# ("'SimpleX Directory" <> suffix <> "'> > " <> name) u <## " Found 1 group(s)." u <#. ("'SimpleX Directory" <> suffix <> "'> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name) - u <## "Welcome message:" u <##. "Link to join the group " u <## (show count <> " members") +groupFoundWelcome :: HasCallStack => Int -> TestCC -> String -> String -> IO () +groupFoundWelcome count u name welcome = do + u #> ("@'SimpleX Directory' " <> name) + u <# ("'SimpleX Directory'> > " <> name) + u <## " Found 1 group(s)." + u <#. ("'SimpleX Directory'> " <> name) + u <## "Welcome message:" + u <## welcome + u <##. "Link to join the group " + u <## (show count <> " members") + +getGroupLinkFromBot :: HasCallStack => TestCC -> IO String +getGroupLinkFromBot u = do + u #> "@'SimpleX Directory' /link 1" + u <# "'SimpleX Directory'> > /link 1" + u <## " The link to join the group ID 1 (privacy):" + gLink <- getTermLine u + u <## "New member role: member" + pure gLink + groupNotFound :: TestCC -> String -> IO () groupNotFound = groupNotFound_ "" @@ -2034,7 +2008,7 @@ testHelpNoAudio ps = bob <## "/list - list the groups you registered." bob <## "`/role ` - view and set default member role for your group." bob <## "`/filter ` - view and set spam filter settings for group." - bob <## "`/link ` - view and upgrade group link." + bob <## "`/link ` - view group link." bob <## "`/delete :` - remove the group you submitted from directory, with ID and name as shown by /list command." bob <## "" bob <## "To search for groups, send the search text."