From 2f10e057e22734389a6e3ea035c07d70c455ce77 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 1 Jul 2026 13:42:26 +0100 Subject: [PATCH] feat(directory): harden group member admission (#7180) * feat(directory): harden group member admission Default new registered groups to requiring a captcha and advise owners of recommended public-group settings at registration submission. Add CLI flags to override per-group admission policy directory-wide: - --prohibited-to-observer: delete a member's message and demote them to observer when they post content prohibited by the group's settings - --always-captcha: require a captcha from joining members in all groups - --knocking: require admin review before admitting members in all groups * fix(directory): reword recommended settings notice Address review: replace the enumerated settings list with a concise recommendation and reference the group's filter command by id. --------- Co-authored-by: shum --- .../src/Directory/Events.hs | 8 +- .../src/Directory/Options.hs | 21 ++ .../src/Directory/Service.hs | 46 +++- .../src/Directory/Store.hs | 11 + tests/Bots/DirectoryTests.hs | 238 +++++++++++------- 5 files changed, 226 insertions(+), 98 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index bfbc025a49..3bff611a28 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -27,7 +27,7 @@ import qualified Data.Attoparsec.Text as A import Data.Char (isSpace) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -38,6 +38,7 @@ import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink, MsgContent (..)) import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences (GroupFeature) import Simplex.Chat.Types.Shared import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) import Simplex.Messaging.Encoding.String @@ -52,6 +53,7 @@ data DirectoryEvent | DEGroupLinkCheck GroupInfo | DEPendingMember GroupInfo GroupMember | DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text + | DEGroupItemProhibited GroupInfo GroupMember ChatItemId GroupFeature -- a member posted content prohibited by the group's settings | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed | DEServiceRoleChanged GroupInfo GroupMemberRole | DEContactRemovedFromGroup ContactId GroupInfo @@ -84,8 +86,10 @@ crDirectoryEvent_ = \case CEvtJoinedGroupMember {groupInfo, member = m} | pending m -> Just $ DEPendingMember groupInfo m | otherwise -> Nothing - CEvtNewChatItems {chatItems = AChatItem _ _ (GroupChat g _scopeInfo) ci : _} -> case ci of + CEvtNewChatItems {chatItems = AChatItem _ _ (GroupChat g scopeInfo) ci : _} -> case ci of ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t)} | pending m -> Just $ DEPendingMemberMsg g m (chatItemId' ci) t + -- only moderate prohibited content in the main group, not in member-support/onboarding scope + ChatItem {chatDir = CIGroupRcv m, content = CIRcvGroupFeatureRejected gf} | isNothing scopeInfo -> Just $ DEGroupItemProhibited g m (chatItemId' ci) gf _ -> Nothing CEvtMemberRole {groupInfo, member, toRole} | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 5d51023781..23115ec7c7 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -44,6 +44,9 @@ data DirectoryOpts = DirectoryOpts searchResults :: Int, webFolder :: Maybe FilePath, linkCheckInterval :: Int, + prohibitedToObserver :: Bool, + alwaysCaptcha :: Bool, + knocking :: Bool, testing :: Bool } @@ -177,6 +180,21 @@ directoryOpts appDir defaultDbName = do <> help "Interval in seconds to check public group link data (default: 1800)" <> value 1800 ) + prohibitedToObserver <- + switch + ( long "prohibited-to-observer" + <> help "Set a member to observer (and delete the message) when they post content prohibited by the group's settings" + ) + alwaysCaptcha <- + switch + ( long "always-captcha" + <> help "Require a captcha from joining members in all groups, regardless of per-group filter settings" + ) + knocking <- + switch + ( long "knocking" + <> help "Require admin review (knocking) before joining members are admitted in all groups, regardless of group preference" + ) pure DirectoryOpts { coreOptions, @@ -199,6 +217,9 @@ directoryOpts appDir defaultDbName = do searchResults = 10, webFolder, linkCheckInterval, + prohibitedToObserver, + alwaysCaptcha, + knocking, testing = False } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 63e1a0ff69..bedcb87da3 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -271,7 +271,7 @@ directoryService st opts cfg = do acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)) acceptMemberHook - DirectoryOpts {profileNameLimit} + DirectoryOpts {profileNameLimit, alwaysCaptcha, knocking} ServiceState {blockedWordsCfg} g GroupLinkInfo {memberRole} @@ -280,7 +280,8 @@ acceptMemberHook when (useMemberFilter img $ rejectNames a) checkName pure $ if - | useMemberFilter img (passCaptcha a) -> (GAPendingApproval, GRMember) + | knocking -> (GAPendingReview, memberRole) + | alwaysCaptcha || useMemberFilter img (passCaptcha a) -> (GAPendingApproval, GRMember) | useMemberFilter img (makeObserver a) -> (GAAccepted, GRObserver) | otherwise -> (GAAccepted, memberRole) where @@ -294,6 +295,11 @@ acceptMemberHook groupMemberAcceptance :: GroupInfo -> DirectoryMemberAcceptance groupMemberAcceptance GroupInfo {customData} = (\DirectoryGroupData {memberAcceptance = ma} -> ma) $ fromCustomData customData +recommendedSettingsNotice :: UserGroupRegId -> Text +recommendedSettingsNotice userGroupId = + "We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them.\n\ + \Captcha verification is enabled. Use /'filter " <> tshow userGroupId <> "' to change it." + useMemberFilter :: Maybe ImageData -> Maybe ProfileCondition -> Bool useMemberFilter img_ = \case Just PCAll -> True @@ -311,7 +317,7 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} directoryServiceEvent :: DirectoryLog -> DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () -directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} user@User {userId} cc = \case +directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner @@ -319,6 +325,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName DEGroupLinkCheck g -> deGroupLinkCheck g DEPendingMember g m -> dePendingMember g m DEPendingMemberMsg g m ciId t -> dePendingMemberMsg g m ciId t + DEGroupItemProhibited g m ciId gf -> when prohibitedToObserver $ deGroupItemProhibited g m ciId gf DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role DEServiceRoleChanged g role -> deServiceRoleChanged g role DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g @@ -404,7 +411,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName processInvitation :: Contact -> GroupInfo -> Maybe GroupReg -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = \case - Nothing -> addGroupReg notifyAdminUsers st cc ct g GRSProposed joinGroup + Nothing -> addGroupReg notifyAdminUsers st cc user ct g GRSProposed joinGroup Just _gr -> setGroupStatus notifyAdminUsers st env cc groupId GRSProposed joinGroup where joinGroup _ = do @@ -436,7 +443,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Left e -> sendMessage cc ct $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e where askConfirmation = - addGroupReg notifyAdminUsers st cc ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do + addGroupReg notifyAdminUsers st cc user ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do sendMessage cc ct $ "The group " <> groupNameDescr p <> " is already submitted to the directory.\nTo confirm the registration, please send:" sendMessage cc ct $ "/confirm " <> tshow userGroupRegId <> ":" <> viewName displayName @@ -488,6 +495,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName \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." @@ -650,6 +658,19 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName "Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "." <> if canSendVoiceCaptcha g m then "\nSend /audio to receive a voice captcha." else "" + -- gated by --prohibited-to-observer at the dispatch above + deGroupItemProhibited :: GroupInfo -> GroupMember -> ChatItemId -> GroupFeature -> IO () + deGroupItemProhibited GroupInfo {groupId} m@GroupMember {memberRole} ciId gf = + when (memberRole == GRMember) $ do + let gmId = groupMemberId' m + logInfo $ "Member " <> tshow gmId <> " posted prohibited content (" <> tshow gf <> ") in group " <> tshow groupId <> "; deleting and setting to observer" + sendChatCmd cc (APIDeleteMemberChatItem groupId [ciId]) >>= \case + Right CRChatItemsDeleted {} -> pure () + r -> logError $ "deGroupItemProhibited: unexpected delete response: " <> tshow r + sendChatCmd cc (APIMembersRole groupId [gmId] GRObserver) >>= \case + Right CRMembersRoleUser {} -> pure () -- empty members = already observer (idempotent), still success + r -> logError $ "deGroupItemProhibited: unexpected set observer response: " <> tshow r + sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> CaptchaMode -> IO () sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts mode = do s <- getCaptchaStr captchaLength "" @@ -776,7 +797,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} = - useMemberFilter image $ passCaptcha a + alwaysCaptcha || useMemberFilter image (passCaptcha a) sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () sendToApprove GroupInfo {groupId, groupProfile = p@GroupProfile {displayName, image = image', publicGroup = pg_}, groupSummary} GroupReg {dbContactId, promoted} gaId = do @@ -982,7 +1003,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName sendChatCmd cc (APIPrepareGroup userId ccLink False groupSLinkData) >>= \case Right (CRNewPreparedChat _ (AChat SCTGroup (Chat (GroupChat gInfo _) _ _))) -> do let gId = groupId' gInfo - addGroupReg notifyAdminUsers st cc ct gInfo GRSProposed $ \_ -> pure () + addGroupReg notifyAdminUsers st cc user ct gInfo GRSProposed $ \_ -> pure () sendChatCmd cc (APIConnectPreparedGroup gId False (Just ownerContact) Nothing) >>= \case Right CRStartedConnectionToGroup {groupInfo = gInfo'} -> withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user gInfo' mId) >>= \case @@ -1007,7 +1028,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName | contactId' ct `isOwner` gr -> sameOwnerReregistration gr gt | otherwise -> sendMessage cc ct $ "This " <> gt <> " is registered by another owner." Left _ -> - addGroupReg notifyAdminUsers st cc ct g (GRSPendingApproval 1) $ \gr -> do + addGroupReg notifyAdminUsers st cc user ct g (GRSPendingApproval 1) $ \gr -> do void $ setGroupRegOwner cc groupId ownerMember sendToApprove g gr 1 | role < GROwner -> sendMessage cc ct $ "You must be the " <> gt <> " owner to register it." @@ -1045,6 +1066,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName in if role >= GROwner then setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do notifyOwner gr' $ "Joined the " <> gt <> " " <> displayName <> ". Registration is pending approval — it may take up to 48 hours." + notifyOwner gr' $ recommendedSettingsNotice (userGroupRegId gr') sendToApprove g gr' 1 else do setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \_ -> pure () @@ -1484,12 +1506,16 @@ setGroupStatusPromo sendReply st env cc GroupReg {dbGroupId = gId} grStatus' grP logGUpdatePromotion st gId grPromoted' continue -addGroupReg :: (Text -> IO ()) -> DirectoryLog -> ChatController -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () -addGroupReg sendMsg st cc ct g@GroupInfo {groupId} grStatus continue = +addGroupReg :: (Text -> IO ()) -> DirectoryLog -> ChatController -> User -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () +addGroupReg sendMsg st cc user ct g@GroupInfo {groupId} grStatus continue = addGroupRegStore cc ct g grStatus >>= \case Left e -> sendMsg $ "Error creating group registation for group " <> tshow groupId <> ": " <> T.pack e Right gr -> do logGCreate st gr + let d = toCustomData $ DirectoryGroupData newGroupJoinFilter + withDB' "setGroupCustomData" cc (\db -> setGroupCustomData db user g $ Just d) >>= \case + Right () -> pure () + Left e -> sendMsg $ "Error setting default captcha for group " <> tshow groupId <> ": " <> T.pack e continue gr setGroupStatus :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 89c5178f7d..a9a9788e0f 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -52,6 +52,7 @@ module Directory.Store basicJoinFilter, moderateJoinFilter, strongJoinFilter, + newGroupJoinFilter, groupDBError, logGCreate, logGDelete, @@ -164,6 +165,16 @@ strongJoinFilter = makeObserver = Nothing } +-- Default applied to newly registered groups: a captcha challenge is required +-- from every joining member unless the owner changes it with /filter. +newGroupJoinFilter :: DirectoryMemberAcceptance +newGroupJoinFilter = + DirectoryMemberAcceptance + { rejectNames = Nothing, + passCaptcha = Just PCAll, + makeObserver = Nothing + } + type UserGroupRegId = Int64 type GroupApprovalId = Int64 diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index cd6d549581..438a3f9802 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -74,6 +74,9 @@ directoryServiceTests = do describe "list and promote groups" $ do it "should list and promote user's groups" $ testListUserGroups True describe "member admission" $ do + it "should require captcha by default for new groups" testCaptchaByDefault + it "should require captcha in all groups with --always-captcha" testAlwaysCaptcha + it "should require admin review in all groups with --knocking" testKnocking it "should ask member to pass captcha screen" testCapthaScreening it "should send voice captcha on /audio command" testVoiceCaptchaScreening it "should retry with voice captcha after switching to audio mode" testVoiceCaptchaRetry @@ -133,6 +136,9 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = searchResults = 3, webFolder, linkCheckInterval = 0, + prohibitedToObserver = False, + alwaysCaptcha = False, + knocking = False, testing = True } @@ -169,6 +175,8 @@ testDirectoryService ps = bob <## "Please add it to the group welcome message." bob <## "For example, add:" welcomeWithLink <- dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine bob + 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" updateGroupProfile bob "Welcome!" bob <# "'SimpleX Directory'> The profile updated for ID 1 (PSA), but the group link is not added to the welcome message." @@ -396,6 +404,14 @@ testSetRole ps = cath ##> ("/c " <> groupLink) cath <## "connection request sent!" cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group, pending approval" + cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service." + cath <## "" + cath <## "Send captcha text to join the group privacy." + captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath + cath #> ("#privacy (support) " <> captcha) + 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" @@ -428,12 +444,18 @@ testJoinGroup ps = cath ##> ("/c " <> groupLink) cath <## "connection request sent!" cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group, pending approval" + cath <# "#privacy (support) 'SimpleX Directory_1'> Captcha is generated by SimpleX Directory service." + cath <## "" + cath <## "Send captcha text to join the group privacy." + captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory_1'> " . dropTime <$> getTermLine cath + cath #> ("#privacy (support) " <> captcha) + cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'" + cath <## "use @'SimpleX Directory' to send messages" + cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) + cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" - cath - <### [ "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'", - "use @'SimpleX Directory' to send messages", - Predicate (\l -> l == welcomeMsg || dropTime_ l == Just ("#privacy 'SimpleX Directory'> " <> welcomeMsg) || dropTime_ l == Just ("#privacy 'SimpleX Directory_1'> " <> welcomeMsg)) - ] + 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" @@ -788,7 +810,7 @@ testNotSentApprovalBadRoles ps = bob `connectVia` dsLink cath `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" + welcomeWithLink <- groupAccepted bob "privacy" 1 bob ##> "/mr privacy 'SimpleX Directory' member" bob <## "#privacy: you changed the role of 'SimpleX Directory' to member" updateProfileWithLink bob "privacy" welcomeWithLink 1 @@ -811,7 +833,7 @@ testNotApprovedBadRoles ps = bob `connectVia` dsLink cath `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" + welcomeWithLink <- groupAccepted bob "privacy" 1 updateProfileWithLink bob "privacy" welcomeWithLink 1 notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 bob ##> "/mr privacy 'SimpleX Directory' member" @@ -1019,14 +1041,14 @@ testDuplicateAskConfirmation ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - _ <- groupAccepted bob "privacy" + _ <- 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" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink <- groupAccepted cath "privacy" + welcomeWithLink <- groupAccepted cath "privacy" 1 groupNotFound bob "privacy" completeRegistrationId superUser cath "privacy" "Privacy" welcomeWithLink 2 1 groupFound bob "privacy" @@ -1050,7 +1072,7 @@ testDuplicateProhibitConfirmation ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" + welcomeWithLink <- groupAccepted bob "privacy" 1 cath `connectVia` dsLink submitGroup cath "privacy" "Privacy" cath <# "'SimpleX Directory'> The group privacy (Privacy) is already submitted to the directory." @@ -1069,14 +1091,14 @@ testDuplicateProhibitWhenUpdated ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" + welcomeWithLink <- 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" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink' <- groupAccepted cath "privacy" + welcomeWithLink' <- groupAccepted cath "privacy" 1 groupNotFound cath "privacy" completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 groupFound cath "privacy" @@ -1100,14 +1122,14 @@ testDuplicateProhibitApproval ps = withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink submitGroup bob "privacy" "Privacy" - welcomeWithLink <- groupAccepted bob "privacy" + welcomeWithLink <- 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" cath #> "@'SimpleX Directory' /confirm 1:privacy" - welcomeWithLink' <- groupAccepted cath "privacy" + welcomeWithLink' <- groupAccepted cath "privacy" 1 updateProfileWithLink cath "privacy" welcomeWithLink' 1 notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2 groupNotFound cath "privacy" @@ -1194,6 +1216,100 @@ checkListings listed promoted = do map groupName gs `shouldBe` expected groupName DirectoryEntry {displayName} = displayName +testAlwaysCaptcha :: HasCallStack => TestParams -> IO () +testAlwaysCaptcha ps = + withDirectoryServiceOpts ps (\o -> o {alwaysCaptcha = True}) $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + -- disable the per-group captcha filter; --always-captcha must still force it + bob #> "@'SimpleX Directory' /filter 1 off" + bob <# "'SimpleX Directory'> > /filter 1 off" + bob <## " Spam filter settings for group privacy set to:" + bob <## "- reject long/inappropriate names: disabled" + bob <## "- pass captcha to join: disabled" + bob <## "" + bob <## "/'filter 1 name' - enable name filter" + bob <## "/'filter 1 captcha' - enable captcha challenge" + bob <## "/'filter 1 name captcha' - enable both" + bob #> "@'SimpleX Directory' /role 1" + bob <# "'SimpleX Directory'> > /role 1" + bob <## " The initial member role for the group privacy is set to member" + bob <## "Send /'role 1 observer' to change it." + bob <## "" + note <- getTermLine bob + let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note + cath ##> ("/c " <> groupLink) + cath <## "connection request sent!" + cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group, pending approval" + cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service." + cath <## "" + cath <## "Send captcha text to join the group privacy." + captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath + cath #> ("#privacy (support) " <> captcha) + 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" + +testKnocking :: HasCallStack => TestParams -> IO () +testKnocking ps = + withDirectoryServiceOpts ps (\o -> o {knocking = True}) $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + bob #> "@'SimpleX Directory' /role 1" + bob <# "'SimpleX Directory'> > /role 1" + bob <## " The initial member role for the group privacy is set to member" + bob <## "Send /'role 1 observer' to change it." + bob <## "" + note <- getTermLine bob + let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note + cath ##> ("/c " <> groupLink) + cath <## "connection request sent!" + cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group, connecting to group moderators for admission to group" + cath <## "#privacy: 'SimpleX Directory' accepted you to the group, pending review" + bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting and pending review...), use /_accept member #1 3 to accept member" + +testCaptchaByDefault :: HasCallStack => TestParams -> IO () +testCaptchaByDefault ps = + withDirectoryService ps $ \superUser dsLink -> + withNewTestChat ps "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + -- the owner never ran /filter; captcha is on by default for new groups + bob #> "@'SimpleX Directory' /role 1" + bob <# "'SimpleX Directory'> > /role 1" + bob <## " The initial member role for the group privacy is set to member" + bob <## "Send /'role 1 observer' to change it." + bob <## "" + note <- getTermLine bob + let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note + cath ##> ("/c " <> groupLink) + cath <## "connection request sent!" + cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group, pending approval" + cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service." + cath <## "" + cath <## "Send captcha text to join the group privacy." + captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath + cath #> ("#privacy (support) " <> captcha) + 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" + testCapthaScreening :: HasCallStack => TestParams -> IO () testCapthaScreening ps = withDirectoryService ps $ \superUser dsLink -> @@ -1209,16 +1325,6 @@ testCapthaScreening ps = bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - -- enable captcha - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" -- connect with captcha screen _ <- join cath groupLink cath #> "#privacy (support) 123" -- sending incorrect captcha @@ -1307,16 +1413,6 @@ testVoiceCaptchaScreening ps@TestParams {tmpPath} = do bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - -- enable captcha - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" -- cath joins, receives text captcha with /audio hint cath ##> ("/c " <> groupLink) cath <## "connection request sent!" @@ -1376,15 +1472,6 @@ testVoiceCaptchaRetry ps@TestParams {tmpPath} = do bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" -- cath joins, receives text captcha with /audio hint cath ##> ("/c " <> groupLink) cath <## "connection request sent!" @@ -1437,15 +1524,6 @@ testVoiceCaptchaVoiceDisabled ps@TestParams {tmpPath} = do bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" -- disable voice messages in the group bob ##> "/set voice #privacy off" bob <## "updated group preferences:" @@ -1504,15 +1582,6 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" -- disable voice messages in the group bob ##> "/set voice #privacy off" bob <## "updated group preferences:" @@ -1543,20 +1612,24 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" -withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO () -withDirectoryServiceVoiceCaptcha ps voiceScript test = do +withDirectoryServiceOpts :: HasCallStack => TestParams -> (DirectoryOpts -> DirectoryOpts) -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceOpts ps modOpts test = do dsLink <- withNewTestChatCfg ps testCfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps testCfg "super_user" aliceProfile $ \superUser -> do connectUsers ds superUser ds ##> "/ad" getContactLink ds True - let opts = (mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing) {voiceCaptchaGenerator = Just voiceScript} + let opts = modOpts $ mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing runDirectory testCfg opts $ withTestChatCfg ps testCfg "super_user" $ \superUser -> do superUser <## "subscribed 1 connections on server localhost" test superUser dsLink +withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceVoiceCaptcha ps voiceScript = + withDirectoryServiceOpts ps (\o -> o {voiceCaptchaGenerator = Just voiceScript}) + testRestoreDirectory :: HasCallStack => TestParams -> IO () testRestoreDirectory ps = do testListUserGroups False ps @@ -1729,7 +1802,7 @@ 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 + welcomeWithLink <- groupAccepted u n ugId completeRegistrationId su u n fn welcomeWithLink gId ugId submitGroup :: TestCC -> String -> String -> IO () @@ -1740,8 +1813,8 @@ 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 -> IO String -groupAccepted u n = do +groupAccepted :: TestCC -> String -> Int -> IO String +groupAccepted u n ugId = do u <### [ WithTime ("'SimpleX Directory'> Joining the group " <> n <> "…"), ConsoleString ("#" <> viewName n <> ": 'SimpleX Directory' joined the group") @@ -1751,7 +1824,10 @@ groupAccepted u n = do u <## "" u <## "Please add it to the group welcome message." u <## "For example, add:" - dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine u -- welcome message with link + welcomeWithLink <- dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine u + 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 = @@ -1885,15 +1961,6 @@ testCaptchaTooManyAttempts ps = bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" cath ##> ("/c " <> groupLink) cath <## "connection request sent!" cath <## "#privacy: joining the group..." @@ -1932,15 +1999,6 @@ testCaptchaUnknownCommand ps = bob <## "" note <- getTermLine bob let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note - bob #> "@'SimpleX Directory' /filter 1 captcha" - bob <# "'SimpleX Directory'> > /filter 1 captcha" - bob <## " Spam filter settings for group privacy set to:" - bob <## "- reject long/inappropriate names: disabled" - bob <## "- pass captcha to join: enabled" - bob <## "" - bob <## "/'filter 1 name' - enable name filter" - bob <## "/'filter 1 name captcha' - enable both" - bob <## "/'filter 1 off' - disable filter" cath ##> ("/c " <> groupLink) cath <## "connection request sent!" cath <## "#privacy: joining the group..." @@ -2003,6 +2061,8 @@ testRegisterChannelViaCard ps = ] -- owner sends a message to trigger member introduction bob <# "'SimpleX Directory'> Joined the channel news. 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." superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2101,6 +2161,8 @@ testDeleteChannelRegistration ps = bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" ] bob <# "'SimpleX Directory'> Joined the channel news. 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." superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2145,6 +2207,8 @@ testReregistrationAlreadyListed ps = bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" ] bob <# "'SimpleX Directory'> Joined the channel news. 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." superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2204,6 +2268,8 @@ testLinkCheckUpdatesCount ps = do bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" ] bob <# "'SimpleX Directory'> Joined the channel news. 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." superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: "