mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 20:29:53 +00:00
directory: joining groups with enabled captcha screening and observer role (#5784)
* directory: joining groups with enabled captcha screen (test) * fix directory, test * query plans
This commit is contained in:
Evgeny
GitHub
parent
4443786474
commit
27f2926aed
4 changed files with 122 additions and 31 deletions
|
|
@ -469,7 +469,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
|
||||
approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO ()
|
||||
approvePendingMember a g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName, image}} = do
|
||||
gli_ <- join <$> withDB' cc (\db -> getGroupLinkInfo db userId groupId)
|
||||
gli_ <- join <$> withDB' "getGroupLinkInfo" cc (\db -> getGroupLinkInfo db userId groupId)
|
||||
let role = if useMemberFilter image (makeObserver a) then GRObserver else maybe GRMember (\GroupLinkInfo {memberRole} -> memberRole) gli_
|
||||
gmId = groupMemberId' m
|
||||
sendChatCmd cc (APIAcceptMember groupId gmId role) >>= \case
|
||||
|
|
@ -698,7 +698,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
case acceptance_ of
|
||||
Just a' | a /= a' -> do
|
||||
let d = toCustomData $ DirectoryGroupData a'
|
||||
withDB' cc (\db -> setGroupCustomData db user g $ Just d) >>= \case
|
||||
withDB' "setGroupCustomData" cc (\db -> setGroupCustomData db user g $ Just d) >>= \case
|
||||
Just () -> sendSettigns n a' " set to"
|
||||
Nothing -> sendReply $ "Error changing spam filter settings for group " <> n
|
||||
_ -> sendSettigns n a ""
|
||||
|
|
@ -977,24 +977,24 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
sendComposedMessage cc ct Nothing $ MCText text
|
||||
|
||||
getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact)
|
||||
getContact' cc user ctId = withDB cc $ \db -> getContact db (vr cc) user ctId
|
||||
getContact' cc user ctId = withDB "getContact" cc $ \db -> getContact db (vr cc) user ctId
|
||||
|
||||
getGroup :: ChatController -> User -> GroupId -> IO (Maybe GroupInfo)
|
||||
getGroup cc user gId = withDB cc $ \db -> getGroupInfo db (vr cc) user gId
|
||||
getGroup cc user gId = withDB "getGroupInfo" cc $ \db -> getGroupInfo db (vr cc) user gId
|
||||
|
||||
withDB' :: ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
|
||||
withDB' cc a = withDB cc $ ExceptT . fmap Right . a
|
||||
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
|
||||
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
|
||||
|
||||
withDB :: ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a)
|
||||
withDB ChatController {chatStore} action = do
|
||||
withDB :: Text -> ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a)
|
||||
withDB cxt ChatController {chatStore} action = do
|
||||
r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors
|
||||
case r_ of
|
||||
Right r -> pure $ Just r
|
||||
Left e -> Nothing <$ logError ("Database error: " <> tshow e)
|
||||
Left e -> Nothing <$ logError ("Database error: " <> cxt <> " " <> tshow e)
|
||||
|
||||
getGroupAndSummary :: ChatController -> User -> GroupId -> IO (Maybe (GroupInfo, GroupSummary))
|
||||
getGroupAndSummary cc user gId =
|
||||
withDB cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId)
|
||||
withDB "getGroupAndSummary" cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId)
|
||||
|
||||
vr :: ChatController -> VersionRangeChat
|
||||
vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
|
||||
|
|
@ -1002,7 +1002,7 @@ vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
|
|||
|
||||
getGroupLinkRole :: ChatController -> User -> GroupInfo -> IO (Maybe (Int64, ConnReqContact, GroupMemberRole))
|
||||
getGroupLinkRole cc user gInfo =
|
||||
withDB cc $ \db -> getGroupLink db user gInfo
|
||||
withDB "getGroupLink" cc $ \db -> getGroupLink db user gInfo
|
||||
|
||||
setGroupLinkRole :: ChatController -> GroupInfo -> GroupMemberRole -> IO (Maybe ConnReqContact)
|
||||
setGroupLinkRole cc GroupInfo {groupId} mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole groupId mRole)
|
||||
|
|
|
|||
|
|
@ -492,15 +492,14 @@ getUserAddress db User {userId} =
|
|||
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
|
||||
getUserContactLinkById db userId userContactLinkId =
|
||||
ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $
|
||||
DB.query db (groupLinkInfoQuery <> " AND user_contact_link_id = ?") (userId, userContactLinkId)
|
||||
|
||||
groupLinkInfoQuery :: Query
|
||||
groupLinkInfoQuery =
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
|]
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND user_contact_link_id = ?
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
|
||||
toGroupLinkInfo :: (Maybe GroupId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
|
||||
toGroupLinkInfo (groupId_, mRole_) =
|
||||
|
|
@ -510,7 +509,14 @@ toGroupLinkInfo (groupId_, mRole_) =
|
|||
getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
|
||||
getGroupLinkInfo db userId groupId =
|
||||
fmap join $ maybeFirstRow toGroupLinkInfo $
|
||||
DB.query db (groupLinkInfoQuery <> " AND group_id = ?") (userId, groupId)
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND group_id = ?
|
||||
|]
|
||||
(userId, groupId)
|
||||
|
||||
getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
|
||||
getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
|
||||
|
|
|
|||
|
|
@ -2950,6 +2950,14 @@ Query:
|
|||
Plan:
|
||||
SEARCH user_contact_links USING INDEX sqlite_autoindex_user_contact_links_1 (user_id=? AND local_display_name=?)
|
||||
|
||||
Query:
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND user_contact_link_id = ?
|
||||
|
||||
Plan:
|
||||
SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id,
|
||||
conn_status, conn_type, contact_conn_initiated, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id,
|
||||
|
|
@ -4642,14 +4650,6 @@ SEARCH c USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
|
|||
CORRELATED SCALAR SUBQUERY 1
|
||||
SEARCH cc USING COVERING INDEX idx_connections_group_member (user_id=? AND group_member_id=?)
|
||||
|
||||
Query:
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
AND user_contact_link_id = ?
|
||||
Plan:
|
||||
SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
SELECT f.file_id, f.ci_file_status, f.file_path
|
||||
FROM chat_items i
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ import Directory.Service
|
|||
import Directory.Store
|
||||
import GHC.IO.Handle (hClose)
|
||||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options (CoreChatOpts (..))
|
||||
import Simplex.Chat.Options.DB
|
||||
|
|
@ -64,6 +64,8 @@ directoryServiceTests = do
|
|||
it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval
|
||||
describe "list groups" $ do
|
||||
it "should list user's groups" testListUserGroups
|
||||
describe "member admission" $ do
|
||||
it "should ask member to pass captcha screen" testCapthaScreening
|
||||
describe "store log" $ do
|
||||
it "should restore directory service state" testRestoreDirectory
|
||||
describe "captcha" $ do
|
||||
|
|
@ -954,6 +956,88 @@ testListUserGroups ps =
|
|||
groupNotFound cath "anonymity"
|
||||
listGroups superUser bob cath
|
||||
|
||||
testCapthaScreening :: HasCallStack => TestParams -> IO ()
|
||||
testCapthaScreening ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
-- check default role
|
||||
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
|
||||
-- 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 <## "Use /filter 1 [name] [captcha] to enable and /filter 1 off to disable filter."
|
||||
-- connect with captcha screen
|
||||
_ <- join cath groupLink
|
||||
cath #> "#privacy 123" -- sending incorrect captcha
|
||||
cath <# "#privacy SimpleX-Directory!> > cath 123"
|
||||
cath <## " Incorrect text, please try again."
|
||||
captcha <- dropStrPrefix "#privacy 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"
|
||||
cath #> "#privacy hello"
|
||||
bob <# "#privacy cath> hello"
|
||||
cath ##> "/l privacy"
|
||||
cath <## "#privacy: you left the group"
|
||||
cath <## "use /d #privacy to delete the group"
|
||||
bob <## "#privacy: cath left the group"
|
||||
cath ##> "/d #privacy"
|
||||
cath <## "#privacy: you deleted the group"
|
||||
-- change default role to observer
|
||||
bob #> "@SimpleX-Directory /role 1 observer"
|
||||
bob <# "SimpleX-Directory> > /role 1 observer"
|
||||
bob <## " The initial member role for the group privacy is set to observer"
|
||||
bob <## ""
|
||||
bob <##. "Please note: it applies only to members joining via this link: https://"
|
||||
-- connect with captcha screen again, as observer
|
||||
captcha' <- join cath groupLink
|
||||
sendCaptcha cath captcha'
|
||||
-- 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"
|
||||
cath ##> "#privacy hello"
|
||||
cath <## "#privacy: you don't have permission to send messages"
|
||||
(bob </)
|
||||
cath ##> "/ms privacy"
|
||||
cath <## "cath (Catherine): observer, you, connected"
|
||||
cath <## "SimpleX-Directory: admin, host, connected"
|
||||
cath <## "bob (Bob): owner, connected"
|
||||
cath <## (pastMember <> ": author, status unknown")
|
||||
where
|
||||
join cath groupLink = do
|
||||
cath ##> ("/c " <> groupLink)
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group, pending approval"
|
||||
cath <# "#privacy SimpleX-Directory> Captcha is generated by SimpleX Directory service."
|
||||
cath <## ""
|
||||
cath <## "Send captcha text to join the group privacy."
|
||||
dropStrPrefix "#privacy SimpleX-Directory> " . dropTime <$> getTermLine cath
|
||||
sendCaptcha cath captcha = do
|
||||
cath #> ("#privacy " <> captcha)
|
||||
cath <# ("#privacy SimpleX-Directory!> > cath " <> captcha)
|
||||
cath <## " Correct, you joined the group privacy"
|
||||
cath <## "#privacy: you joined the group"
|
||||
|
||||
testRestoreDirectory :: HasCallStack => TestParams -> IO ()
|
||||
testRestoreDirectory ps = do
|
||||
testListUserGroups ps
|
||||
|
|
@ -1137,7 +1221,8 @@ runDirectory cfg opts@DirectoryOpts {directoryLog} action = do
|
|||
where
|
||||
bot st = do
|
||||
env <- newServiceState opts
|
||||
simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts env
|
||||
let cfg' = cfg {chatHooks = defaultChatHooks {acceptMember = Just $ acceptMemberHook opts env}}
|
||||
simplexChatCore cfg' (mkChatOpts opts) $ directoryService st opts env
|
||||
|
||||
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
|
||||
registerGroup su u n fn = registerGroupId su u n fn 1 1
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue