dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-02 00:31:45 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'f/request-roster' into f/msg-signing

Browse Source
This commit is contained in:
spaced4ndy
2026-07-01 17:28:52 +04:00
parent 89e51a8e70 0425b8f678
commit be79bc13d3
5 changed files with 226 additions and 98 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-directory-service/src/Directory/Events.hs
+6 -2
View File
@@ -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
apps/simplex-directory-service/src/Directory/Options.hs
+21
View File
@@ -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
}
apps/simplex-directory-service/src/Directory/Service.hs
+36 -10
View File
@@ -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 ()
apps/simplex-directory-service/src/Directory/Store.hs
+11
View File
@@ -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
tests/Bots/DirectoryTests.hs
+152 -86
View File
@@ -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' <message> 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' <message> 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 <role> 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: "