mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 20:29:53 +00:00
directory: allow admins deleting groups and registering groups with the same name as deleted one; /help commands; better support of other group owners; support link encoding and version changes (#5829)
* allow admins deleting groups from directory and registering groups with same name as deleted one; /help commands * support profile changes by other owners, with/without connection to directory * profile check will succeed when group link encoding or versions change, but the link queues remain the same
This commit is contained in:
Evgeny
GitHub
parent
48b1ef764b
commit
090f576b65
6 changed files with 296 additions and 140 deletions
|
|
@ -11,6 +11,7 @@ module Directory.Events
|
|||
( DirectoryEvent (..),
|
||||
DirectoryCmd (..),
|
||||
ADirectoryCmd (..),
|
||||
DirectoryHelpSection (..),
|
||||
DirectoryRole (..),
|
||||
SDirectoryRole (..),
|
||||
crDirectoryEvent,
|
||||
|
|
@ -25,6 +26,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.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
|
|
@ -45,7 +47,7 @@ data DirectoryEvent
|
|||
= DEContactConnected Contact
|
||||
| DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
|
||||
| DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember}
|
||||
| DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
|
||||
| DEGroupUpdated {member :: GroupMember, fromGroup :: GroupInfo, toGroup :: GroupInfo}
|
||||
| DEPendingMember GroupInfo GroupMember
|
||||
| DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text
|
||||
| DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
|
||||
|
|
@ -66,7 +68,7 @@ crDirectoryEvent = \case
|
|||
CRContactConnected {contact} -> Just $ DEContactConnected contact
|
||||
CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
|
||||
CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember
|
||||
CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
|
||||
CRGroupUpdated {fromGroup, toGroup, member_} -> (\member -> DEGroupUpdated {member, fromGroup, toGroup}) <$> member_
|
||||
CRJoinedGroupMember {groupInfo, member = m}
|
||||
| pending m -> Just $ DEPendingMember groupInfo m
|
||||
| otherwise -> Nothing
|
||||
|
|
@ -137,8 +139,11 @@ deriving instance Show (DirectoryCmdTag r)
|
|||
|
||||
data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r)
|
||||
|
||||
data DirectoryHelpSection = DHSRegistration | DHSCommands
|
||||
deriving (Show)
|
||||
|
||||
data DirectoryCmd (r :: DirectoryRole) where
|
||||
DCHelp :: DirectoryCmd 'DRUser
|
||||
DCHelp :: DirectoryHelpSection -> DirectoryCmd 'DRUser
|
||||
DCSearchGroup :: Text -> DirectoryCmd 'DRUser
|
||||
DCSearchNext :: DirectoryCmd 'DRUser
|
||||
DCAllGroups :: DirectoryCmd 'DRUser
|
||||
|
|
@ -180,7 +185,7 @@ directoryCmdP =
|
|||
(tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t)))
|
||||
<|> pure (ADC SDRUser DCUnknownCommand)
|
||||
tagP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
A.takeTill isSpace >>= \case
|
||||
"help" -> u DCHelp_
|
||||
"h" -> u DCHelp_
|
||||
"next" -> u DCSearchNext_
|
||||
|
|
@ -213,11 +218,19 @@ directoryCmdP =
|
|||
su = pure . ADCT SDRSuperUser
|
||||
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
|
||||
cmdP = \case
|
||||
DCHelp_ -> pure DCHelp
|
||||
DCHelp_ -> DCHelp . fromMaybe DHSRegistration <$> optional (A.takeWhile isSpace *> helpSectionP)
|
||||
where
|
||||
helpSectionP =
|
||||
A.takeText >>= \case
|
||||
"registration" -> pure DHSRegistration
|
||||
"r" -> pure DHSRegistration
|
||||
"commands" -> pure DHSCommands
|
||||
"c" -> pure DHSCommands
|
||||
_ -> fail "bad help section"
|
||||
DCSearchNext_ -> pure DCSearchNext
|
||||
DCAllGroups_ -> pure DCAllGroups
|
||||
DCRecentGroups_ -> pure DCRecentGroups
|
||||
DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (A.takeWhile1 isSpace *> A.takeText)
|
||||
DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (spacesP *> A.takeText)
|
||||
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
|
||||
DCListUserGroups_ -> pure DCListUserGroups
|
||||
DCDeleteGroup_ -> gc DCDeleteGroup
|
||||
|
|
@ -228,7 +241,7 @@ directoryCmdP =
|
|||
DCGroupFilter_ -> do
|
||||
(groupId, displayName_) <- gc_ (,)
|
||||
acceptance_ <-
|
||||
(A.takeWhile (== ' ') >> A.endOfInput) $> Nothing
|
||||
(A.takeWhile isSpace >> A.endOfInput) $> Nothing
|
||||
<|> Just <$> (acceptancePresetsP <|> acceptanceFiltersP)
|
||||
pure $ DCGroupFilter groupId displayName_ acceptance_
|
||||
where
|
||||
|
|
@ -272,15 +285,15 @@ directoryCmdP =
|
|||
where
|
||||
gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP)
|
||||
gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP)
|
||||
-- wordP = spacesP *> A.takeTill (== ' ')
|
||||
spacesP = A.takeWhile1 (== ' ')
|
||||
-- wordP = spacesP *> A.takeTill isSpace
|
||||
spacesP = A.takeWhile1 isSpace
|
||||
|
||||
viewName :: Text -> Text
|
||||
viewName n = if T.any (== ' ') n then "'" <> n <> "'" else n
|
||||
viewName n = if T.any isSpace n then "'" <> n <> "'" else n
|
||||
|
||||
directoryCmdTag :: DirectoryCmd r -> Text
|
||||
directoryCmdTag = \case
|
||||
DCHelp -> "help"
|
||||
DCHelp _ -> "help"
|
||||
DCSearchGroup _ -> "search"
|
||||
DCSearchNext -> "next"
|
||||
DCAllGroups -> "all"
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ import Simplex.Chat.Bot
|
|||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Markdown (FormattedText (..), Format (..), parseMaybeMarkdownList)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (MsgContent (..))
|
||||
|
|
@ -61,6 +62,7 @@ import Simplex.Chat.Types
|
|||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName)
|
||||
import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), SConnectionMode (..), sameConnReqContact)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
|
|
@ -185,13 +187,13 @@ useMemberFilter img_ = \case
|
|||
Nothing -> False
|
||||
|
||||
readBlockedWordsConfig :: DirectoryOpts -> IO BlockedWordsConfig
|
||||
readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules} = do
|
||||
readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules, testing} = do
|
||||
extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules
|
||||
spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile
|
||||
blockedFragments <- S.fromList <$> maybe (pure []) (fmap T.lines . T.readFile) blockedFragmentsFile
|
||||
bws <- maybe (pure []) (fmap lines . readFile) blockedWordsFile
|
||||
let blockedWords = S.fromList $ concatMap (wordVariants extensionRules) bws
|
||||
putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling)
|
||||
unless testing $ putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling)
|
||||
pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling}
|
||||
|
||||
directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO ()
|
||||
|
|
@ -200,7 +202,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
DEContactConnected ct -> deContactConnected ct
|
||||
DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
|
||||
DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner
|
||||
DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup
|
||||
DEGroupUpdated {member, fromGroup, toGroup} -> deGroupUpdated member fromGroup toGroup
|
||||
DEPendingMember g m -> dePendingMember g m
|
||||
DEPendingMemberMsg g m ciId t -> dePendingMemberMsg g m ciId t
|
||||
DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role
|
||||
|
|
@ -253,17 +255,25 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} =
|
||||
getGroups fullName >>= mapM duplicateGroup
|
||||
where
|
||||
sameGroup (GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) =
|
||||
gId /= groupId && n == displayName && fn == fullName
|
||||
sameGroupNotRemoved (g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) =
|
||||
gId /= groupId && n == displayName && fn == fullName && not (memberRemoved $ membership g)
|
||||
duplicateGroup [] = pure DGUnique
|
||||
duplicateGroup groups = do
|
||||
let gs = filter sameGroup groups
|
||||
let gs = filter sameGroupNotRemoved groups
|
||||
if null gs
|
||||
then pure DGUnique
|
||||
else do
|
||||
(lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st)
|
||||
let reserved = any (\(GroupInfo {groupId = gId}, _) -> gId `S.member` lgs || gId `S.member` rgs) gs
|
||||
pure $ if reserved then DGReserved else DGRegistered
|
||||
if reserved
|
||||
then pure DGReserved
|
||||
else do
|
||||
removed <- foldM (\r -> fmap (r &&) . isGroupRemoved) True gs
|
||||
pure $ if removed then DGUnique else DGRegistered
|
||||
isGroupRemoved (GroupInfo {groupId = gId}, _) =
|
||||
getGroupReg st gId >>= \case
|
||||
Just GroupReg {groupRegStatus} -> groupRemoved <$> readTVarIO groupRegStatus
|
||||
Nothing -> pure True
|
||||
|
||||
processInvitation :: Contact -> GroupInfo -> IO ()
|
||||
processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do
|
||||
|
|
@ -354,78 +364,95 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
_ -> notifyOwner gr $ unexpectedError "can't create group link"
|
||||
_ -> notifyOwner gr $ unexpectedError "can't create group link"
|
||||
|
||||
deGroupUpdated :: ContactId -> GroupInfo -> GroupInfo -> IO ()
|
||||
deGroupUpdated ctId fromGroup toGroup = do
|
||||
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 -> do
|
||||
let userGroupRef = userGroupReference gr toGroup
|
||||
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.
|
||||
readTVarIO (groupRegStatus gr) >>= \case
|
||||
GRSPendingConfirmation -> pure ()
|
||||
GRSProposed -> pure ()
|
||||
GRSPendingUpdate ->
|
||||
groupProfileUpdate >>= \case
|
||||
GPNoServiceLink ->
|
||||
when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> userGroupRef <> ", but the group link is not added to the welcome message."
|
||||
GPServiceLinkAdded
|
||||
| ctId `isOwner` gr -> groupLinkAdded gr
|
||||
| otherwise -> notifyOwner gr "The group link is added by another group member, your registration will not be processed.\n\nPlease update the group profile yourself."
|
||||
GPServiceLinkRemoved -> when (ctId `isOwner` gr) $ notifyOwner gr $ "The group link of " <> userGroupRef <> " is removed from the welcome message, please add it."
|
||||
GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr
|
||||
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
|
||||
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers."
|
||||
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 $ n + 1
|
||||
GRSActive -> processProfileChange gr 1
|
||||
GRSSuspended -> processProfileChange gr 1
|
||||
GRSSuspendedBadRoles -> processProfileChange gr 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
|
||||
isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_
|
||||
GroupInfo {groupId, groupProfile = p} = fromGroup
|
||||
GroupInfo {groupProfile = p'} = toGroup
|
||||
sameProfile
|
||||
GroupProfile {displayName = n, fullName = fn, image = i, description = d}
|
||||
GroupProfile {displayName = n', fullName = fn', image = i', description = d'} =
|
||||
n == n' && fn == fn' && i == i' && d == d'
|
||||
groupLinkAdded gr = do
|
||||
groupLinkAdded gr byMember = do
|
||||
getDuplicateGroup toGroup >>= \case
|
||||
Nothing -> notifyOwner gr "Error: getDuplicateGroup. Please notify the developers."
|
||||
Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup
|
||||
_ -> do
|
||||
let gaId = 1
|
||||
setGroupStatus st gr $ GRSPendingApproval gaId
|
||||
notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 48 hours."
|
||||
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
|
||||
processProfileChange gr n' = do
|
||||
processProfileChange gr byMember n' = do
|
||||
setGroupStatus st gr GRSPendingUpdate
|
||||
let userGroupRef = userGroupReference gr toGroup
|
||||
groupRef = groupReference toGroup
|
||||
groupProfileUpdate >>= \case
|
||||
GPNoServiceLink -> do
|
||||
notifyOwner gr $ "The group profile is updated " <> userGroupRef <> ", but no link is added to the welcome message.\n\nThe group will remain hidden from the directory until the group link is added and the group is re-approved."
|
||||
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 -> do
|
||||
notifyOwner gr $ "The group link for " <> userGroupRef <> " is removed from the welcome message.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
|
||||
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 -> do
|
||||
setGroupStatus st gr $ GRSPendingApproval n'
|
||||
notifyOwner gr $ "The group link is added to " <> userGroupRef <> "!\nIt is hidden from the directory until approved."
|
||||
notifyAdminUsers $ "The group link is added to " <> groupRef <> "."
|
||||
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 -> do
|
||||
setGroupStatus st gr $ GRSPendingApproval n'
|
||||
notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved."
|
||||
notifyAdminUsers $ "The group " <> groupRef <> " is updated."
|
||||
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'
|
||||
GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval."
|
||||
groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId)
|
||||
where
|
||||
profileUpdate = \case
|
||||
CRGroupLink {connReqContact} ->
|
||||
let groupLink1 = strEncodeTxt connReqContact
|
||||
groupLink2 = strEncodeTxt $ simplexChatContact connReqContact
|
||||
hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p
|
||||
hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `isInfix` description p'
|
||||
let hadLinkBefore = profileHasGroupLink fromGroup
|
||||
hasLinkNow = profileHasGroupLink toGroup
|
||||
profileHasGroupLink GroupInfo {groupProfile = gp} =
|
||||
maybe False (any ftHasLink) $ parseMaybeMarkdownList =<< description gp
|
||||
ftHasLink = \case
|
||||
FormattedText (Just SimplexLink {simplexUri = ACR SCMContact cr'}) _ -> sameConnReqContact connReqContact cr'
|
||||
_ -> False
|
||||
in if
|
||||
| hadLinkBefore && hasLinkNow -> GPHasServiceLink
|
||||
| hadLinkBefore -> GPServiceLinkRemoved
|
||||
|
|
@ -617,7 +644,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
|
||||
deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO ()
|
||||
deUserCommand ct ciId = \case
|
||||
DCHelp ->
|
||||
DCHelp DHSRegistration ->
|
||||
sendMessage cc ct $
|
||||
"You must be the owner to add the group to the directory:\n\
|
||||
\1. Invite "
|
||||
|
|
@ -628,7 +655,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
<> " bot will create a public group link for the new members to join even when you are offline.\n\
|
||||
\3. You will then need to add this link to the group welcome message.\n\
|
||||
\4. Once the link is added, service admins will approve the group (it can take up to 48 hours), and everybody will be able to find it in directory.\n\n\
|
||||
\Start from inviting the bot to your group as admin - it will guide you through the process"
|
||||
\Start from inviting the bot to your group as admin - it will guide you through the process."
|
||||
DCHelp DHSCommands ->
|
||||
sendMessage cc ct $
|
||||
"*/help commands* - receive this help message.\n\
|
||||
\*/help* - how to register your group to be added to directory.\n\
|
||||
\*/list* - list the groups you registered.\n\
|
||||
\*/delete <ID>:<NAME>* - remove the group you submitted from directory, with _ID_ and _name_ as shown by */list* command.\n\
|
||||
\*/role <ID>* - view and set default member role for your group.\n\
|
||||
\*/filter <ID>* - view and set spam filter settings for group.\n\n\
|
||||
\To search for groups, send the search text."
|
||||
DCSearchGroup s -> withFoundListedGroups (Just s) $ sendSearchResults s
|
||||
DCSearchNext ->
|
||||
atomically (TM.lookup (contactId' ct) searchRequests) >>= \case
|
||||
|
|
@ -667,10 +703,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
"0 registered groups for " <> localDisplayName' ct <> " (" <> tshow (contactId' ct) <> ") out of " <> tshow total <> " registrations"
|
||||
void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
|
||||
sendGroupInfo ct gr userGroupRegId Nothing
|
||||
DCDeleteGroup ugrId gName ->
|
||||
withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do
|
||||
DCDeleteGroup gId gName ->
|
||||
(if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do
|
||||
delGroupReg st gr
|
||||
sendReply $ "Your group " <> displayName <> " is deleted from the directory"
|
||||
sendReply $ (if isAdmin then "The group " else "Your group ") <> displayName <> " is deleted from the directory"
|
||||
DCMemberRole gId gName_ mRole_ ->
|
||||
(if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do
|
||||
let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g
|
||||
|
|
@ -802,9 +838,12 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
|||
setGroupStatus st gr GRSActive
|
||||
let approved = "The group " <> userGroupReference' gr n <> " is approved"
|
||||
notifyOwner gr $
|
||||
(approved <> " and listed in directory!\n")
|
||||
(approved <> " and listed in directory - please moderate it!\n")
|
||||
<> "Please note: if you change the group profile it will be hidden from directory until it is re-approved.\n\n"
|
||||
<> ("Use */filter " <> tshow ugrId <> "* to configure anti-spam filter and */role " <> tshow ugrId <> "* to set default member role.")
|
||||
<> "Supported commands:\n"
|
||||
<> ("- */filter " <> tshow ugrId <> "* - to configure anti-spam filter.\n")
|
||||
<> ("- */role " <> tshow ugrId <> "* - to set default member role.\n")
|
||||
<> "- */help commands* - other commands."
|
||||
invited <-
|
||||
forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do
|
||||
inviteToOwnersGroup og gr $ \case
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ module Directory.Store
|
|||
filterListedGroups,
|
||||
groupRegStatusText,
|
||||
pendingApproval,
|
||||
groupRemoved,
|
||||
fromCustomData,
|
||||
toCustomData,
|
||||
noJoinFilter,
|
||||
|
|
@ -139,13 +140,19 @@ data GroupRegStatus
|
|||
| GRSSuspended
|
||||
| GRSSuspendedBadRoles
|
||||
| GRSRemoved
|
||||
deriving (Show)
|
||||
|
||||
pendingApproval :: GroupRegStatus -> Bool
|
||||
pendingApproval = \case
|
||||
GRSPendingApproval _ -> True
|
||||
_ -> False
|
||||
|
||||
data DirectoryStatus = DSListed | DSReserved | DSRegistered
|
||||
groupRemoved :: GroupRegStatus -> Bool
|
||||
groupRemoved = \case
|
||||
GRSRemoved -> True
|
||||
_ -> False
|
||||
|
||||
data DirectoryStatus = DSListed | DSReserved | DSRegistered | DSRemoved
|
||||
|
||||
groupRegStatusText :: GroupRegStatus -> Text
|
||||
groupRegStatusText = \case
|
||||
|
|
@ -163,6 +170,7 @@ grDirectoryStatus = \case
|
|||
GRSActive -> DSListed
|
||||
GRSSuspended -> DSReserved
|
||||
GRSSuspendedBadRoles -> DSReserved
|
||||
GRSRemoved -> DSRemoved
|
||||
_ -> DSRegistered
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition)
|
||||
|
|
@ -200,8 +208,9 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do
|
|||
| otherwise = mx
|
||||
|
||||
delGroupReg :: DirectoryStore -> GroupReg -> IO ()
|
||||
delGroupReg st GroupReg {dbGroupId = gId} = do
|
||||
delGroupReg st GroupReg {dbGroupId = gId, groupRegStatus} = do
|
||||
logGDelete st gId
|
||||
atomically $ writeTVar groupRegStatus GRSRemoved
|
||||
atomically $ unlistGroup st gId
|
||||
atomically $ modifyTVar' (groupRegs st) $ filter ((gId ==) . dbGroupId)
|
||||
|
||||
|
|
@ -216,6 +225,7 @@ setGroupStatus st gr grStatus = do
|
|||
DSListed -> listGroup
|
||||
DSReserved -> reserveGroup
|
||||
DSRegistered -> unlistGroup
|
||||
DSRemoved -> unlistGroup
|
||||
|
||||
setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO ()
|
||||
setGroupRegOwner st gr owner = do
|
||||
|
|
@ -390,6 +400,7 @@ mkDirectoryStore h groups =
|
|||
DSListed -> (grs', S.insert gId listed, reserved)
|
||||
DSReserved -> (grs', listed, S.insert gId reserved)
|
||||
DSRegistered -> (grs', listed, reserved)
|
||||
DSRemoved -> (grs, listed, reserved)
|
||||
|
||||
mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore
|
||||
mkDirectoryStore_ h (grs, listed, reserved) = do
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ data Format
|
|||
| Secret
|
||||
| Colored {color :: FormatColor}
|
||||
| Uri
|
||||
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
|
||||
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: AConnectionRequestUri, smpHosts :: NonEmpty Text}
|
||||
| Mention {memberName :: Text}
|
||||
| Email
|
||||
| Phone
|
||||
|
|
@ -255,12 +255,12 @@ markdownP = mconcat <$> A.many' fragmentP
|
|||
noFormat = pure . unmarked
|
||||
simplexUriFormat :: AConnectionRequestUri -> Format
|
||||
simplexUriFormat = \case
|
||||
ACR _ (CRContactUri crData) ->
|
||||
let uri = safeDecodeUtf8 . strEncode $ CRContactUri crData {crScheme = SSSimplex}
|
||||
in SimplexLink (linkType' crData) uri $ uriHosts crData
|
||||
ACR _ (CRInvitationUri crData e2e) ->
|
||||
let uri = safeDecodeUtf8 . strEncode $ CRInvitationUri crData {crScheme = SSSimplex} e2e
|
||||
in SimplexLink XLInvitation uri $ uriHosts crData
|
||||
ACR m (CRContactUri crData) ->
|
||||
let cReq = ACR m $ CRContactUri crData {crScheme = SSSimplex}
|
||||
in SimplexLink (linkType' crData) cReq $ uriHosts crData
|
||||
ACR m (CRInvitationUri crData e2e) ->
|
||||
let cReq = ACR m $ CRInvitationUri crData {crScheme = SSSimplex} e2e
|
||||
in SimplexLink XLInvitation cReq $ uriHosts crData
|
||||
where
|
||||
uriHosts ConnReqUriData {crSmpQueues} = L.map (safeDecodeUtf8 . strEncode) $ sconcat $ L.map (host . qServer) crSmpQueues
|
||||
linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ directoryServiceTests = do
|
|||
it "should register group" testDirectoryService
|
||||
it "should suspend and resume group, send message to owner" testSuspendResume
|
||||
it "should delete group registration" testDeleteGroup
|
||||
it "admin should delete group registration" testDeleteGroupAdmin
|
||||
it "should change initial member role" testSetRole
|
||||
it "should join found group via link" testJoinGroup
|
||||
it "should support group names with spaces" testGroupNameWithSpaces
|
||||
|
|
@ -52,10 +53,12 @@ directoryServiceTests = do
|
|||
it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles
|
||||
describe "should require re-approval if profile is changed by" $ do
|
||||
it "the registration owner" testRegOwnerChangedProfile
|
||||
it "another owner" testAnotherOwnerChangedProfile -- TODO fix - doesn't work if another owner is not connected as contact
|
||||
it "another owner" testAnotherOwnerChangedProfile
|
||||
it "another owner not connected to directory" testNotConnectedOwnerChangedProfile
|
||||
describe "should require profile update if group link is removed by " $ do
|
||||
it "the registration owner" testRegOwnerRemovedLink
|
||||
it "another owner" testAnotherOwnerRemovedLink -- TODO fix - doesn't work if another owner is not connected as contact
|
||||
it "another owner" testAnotherOwnerRemovedLink
|
||||
it "another owner not connected to directory" testNotConnectedOwnerRemovedLink
|
||||
describe "duplicate groups (same display name and full name)" $ do
|
||||
it "should ask for confirmation if a duplicate group is submitted" testDuplicateAskConfirmation
|
||||
it "should prohibit registration if a duplicate group is listed" testDuplicateProhibitRegistration
|
||||
|
|
@ -186,10 +189,13 @@ testDirectoryService ps =
|
|||
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!"
|
||||
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 <## "Use /filter 1 to configure anti-spam filter and /role 1 to set default member role."
|
||||
bob <## "Supported commands:"
|
||||
bob <## "- /filter 1 - to configure anti-spam filter."
|
||||
bob <## "- /role 1 - to set default member role."
|
||||
bob <## "- /help commands - other commands."
|
||||
search bob "privacy" welcomeWithLink'
|
||||
search bob "security" welcomeWithLink'
|
||||
cath `connectVia` dsLink
|
||||
|
|
@ -266,6 +272,38 @@ testDeleteGroup ps =
|
|||
bob <## " Your group privacy is deleted from the directory"
|
||||
groupNotFound bob "privacy"
|
||||
|
||||
testDeleteGroupAdmin :: HasCallStack => TestParams -> IO ()
|
||||
testDeleteGroupAdmin ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
cath `connectVia` dsLink
|
||||
registerGroupId superUser cath "security" "Security" 2 1
|
||||
groupFound bob "privacy"
|
||||
groupFound bob "security"
|
||||
listUserGroup bob "privacy" "Privacy"
|
||||
listUserGroup cath "security" "Security"
|
||||
superUser #> "@SimpleX-Directory /last"
|
||||
superUser <# "SimpleX-Directory> > /last"
|
||||
superUser <## " 2 registered group(s)"
|
||||
memberGroupListing superUser bob 1 "privacy" "Privacy" 2 "active"
|
||||
memberGroupListing superUser cath 2 "security" "Security" 2 "active"
|
||||
-- trying to register group with the same name
|
||||
submitGroup bob "security" "Security"
|
||||
bob <# "SimpleX-Directory> The group security (Security) is already listed in the directory, please choose another name."
|
||||
bob ##> "/d #security"
|
||||
bob <## "#security: you deleted the group"
|
||||
-- admin can delete the group
|
||||
superUser #> "@SimpleX-Directory /delete 2:security"
|
||||
superUser <# "SimpleX-Directory> > /delete 2:security"
|
||||
superUser <## " The group security is deleted from the directory"
|
||||
groupFound bob "privacy"
|
||||
groupNotFound bob "security"
|
||||
-- another user can register the group with the same name
|
||||
registerGroupId superUser bob "security" "Security" 4 1
|
||||
|
||||
testSetRole :: HasCallStack => TestParams -> IO ()
|
||||
testSetRole ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
|
|
@ -726,13 +764,34 @@ testAnotherOwnerChangedProfile ps =
|
|||
cath <## "full name changed to: Privacy and Security"
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "full name changed to: Privacy and Security"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath!"
|
||||
bob <## "It is hidden from the directory until approved."
|
||||
groupNotFound cath "privacy"
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath."
|
||||
reapproveGroup 3 superUser bob
|
||||
groupFoundN 3 cath "privacy"
|
||||
|
||||
testNotConnectedOwnerChangedProfile :: HasCallStack => TestParams -> IO ()
|
||||
testNotConnectedOwnerChangedProfile ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
withNewTestChat ps "dan" danProfile $ \dan -> do
|
||||
bob `connectVia` dsLink
|
||||
dan `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
cath ##> "/gp privacy privacy Privacy and Security"
|
||||
cath <## "full name changed to: Privacy and Security"
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "full name changed to: Privacy and Security"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath!"
|
||||
bob <## "It is hidden from the directory until approved."
|
||||
groupNotFound dan "privacy"
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated by cath."
|
||||
reapproveGroup 3 superUser bob
|
||||
groupFoundN 3 dan "privacy"
|
||||
|
||||
testRegOwnerRemovedLink :: HasCallStack => TestParams -> IO ()
|
||||
testRegOwnerRemovedLink ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
|
|
@ -758,14 +817,15 @@ testRegOwnerRemovedLink ps =
|
|||
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
|
||||
cath <## "use @SimpleX-Directory <message> to send messages"
|
||||
groupNotFound cath "privacy"
|
||||
bob ##> ("/set welcome #privacy " <> welcomeWithLink)
|
||||
let withChangedLink = T.unpack $ T.replace "contact#/?v=2-7&" "contact#/?v=3-7&" $ T.pack welcomeWithLink
|
||||
bob ##> ("/set welcome #privacy " <> withChangedLink)
|
||||
bob <## "description changed to:"
|
||||
bob <## welcomeWithLink
|
||||
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 <## "description changed to:"
|
||||
cath <## welcomeWithLink
|
||||
cath <## withChangedLink
|
||||
reapproveGroup 3 superUser bob
|
||||
groupFoundN 3 cath "privacy"
|
||||
|
||||
|
|
@ -789,7 +849,7 @@ testAnotherOwnerRemovedLink ps =
|
|||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description changed to:"
|
||||
bob <## "Welcome!"
|
||||
bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message."
|
||||
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."
|
||||
|
|
@ -800,20 +860,55 @@ testAnotherOwnerRemovedLink ps =
|
|||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description 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 <## "description changed to:"
|
||||
bob <## (welcomeWithLink <> " - welcome!")
|
||||
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
|
||||
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 <## "description changed to:"
|
||||
cath <## (welcomeWithLink <> " - welcome!")
|
||||
reapproveGroup 3 superUser bob
|
||||
groupFoundN 3 cath "privacy"
|
||||
|
||||
testNotConnectedOwnerRemovedLink :: HasCallStack => TestParams -> IO ()
|
||||
testNotConnectedOwnerRemovedLink ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
withNewTestChat ps "dan" danProfile $ \dan -> do
|
||||
bob `connectVia` dsLink
|
||||
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 <## "description changed to:"
|
||||
cath <## "Welcome!"
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description 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 dan "privacy"
|
||||
cath ##> ("/set welcome #privacy " <> welcomeWithLink)
|
||||
cath <## "description changed to:"
|
||||
cath <## welcomeWithLink
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description 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 <## "description 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 <## "description changed to:"
|
||||
-- cath <## (welcomeWithLink <> " - welcome!")
|
||||
reapproveGroup 3 superUser bob
|
||||
groupFoundN 3 dan "privacy"
|
||||
|
||||
testDuplicateAskConfirmation :: HasCallStack => TestParams -> IO ()
|
||||
testDuplicateAskConfirmation ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
|
|
@ -937,14 +1032,7 @@ testListUserGroups ps =
|
|||
cath <## "use @SimpleX-Directory <message> to send messages"
|
||||
registerGroupId superUser bob "security" "Security" 2 2
|
||||
registerGroupId superUser cath "anonymity" "Anonymity" 3 1
|
||||
cath #> "@SimpleX-Directory /list"
|
||||
cath <# "SimpleX-Directory> > /list"
|
||||
cath <## " 1 registered group(s)"
|
||||
cath <# "SimpleX-Directory> 1. anonymity (Anonymity)"
|
||||
cath <## "Welcome message:"
|
||||
cath <##. "Link to join the group anonymity: "
|
||||
cath <## "2 members"
|
||||
cath <## "Status: active"
|
||||
listUserGroup cath "anonymity" "Anonymity"
|
||||
-- with de-listed group
|
||||
groupFound cath "anonymity"
|
||||
cath ##> "/mr anonymity SimpleX-Directory member"
|
||||
|
|
@ -1076,27 +1164,11 @@ testCaptcha _ps = do
|
|||
|
||||
listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO ()
|
||||
listGroups superUser bob cath = do
|
||||
bob #> "@SimpleX-Directory /list"
|
||||
bob <# "SimpleX-Directory> > /list"
|
||||
bob <## " 2 registered group(s)"
|
||||
bob <# "SimpleX-Directory> 1. privacy (Privacy)"
|
||||
bob <## "Welcome message:"
|
||||
bob <##. "Link to join the group privacy: "
|
||||
bob <## "3 members"
|
||||
bob <## "Status: active"
|
||||
bob <# "SimpleX-Directory> 2. security (Security)"
|
||||
bob <## "Welcome message:"
|
||||
bob <##. "Link to join the group security: "
|
||||
bob <## "2 members"
|
||||
bob <## "Status: active"
|
||||
cath #> "@SimpleX-Directory /list"
|
||||
cath <# "SimpleX-Directory> > /list"
|
||||
cath <## " 1 registered group(s)"
|
||||
cath <# "SimpleX-Directory> 1. anonymity (Anonymity)"
|
||||
cath <## "Welcome message:"
|
||||
cath <##. "Link to join the group anonymity: "
|
||||
cath <## "2 members"
|
||||
cath <## "Status: suspended because roles changed"
|
||||
sendListCommand bob 2
|
||||
groupListing bob 1 "privacy" "Privacy" 3 "active"
|
||||
groupListing bob 2 "security" "Security" 2 "active"
|
||||
sendListCommand cath 1
|
||||
groupListing cath 1 "anonymity" "Anonymity" 2 "suspended because roles changed"
|
||||
-- superuser lists all groups
|
||||
bob #> "@SimpleX-Directory /last"
|
||||
bob <# "SimpleX-Directory> > /last"
|
||||
|
|
@ -1104,34 +1176,42 @@ listGroups superUser bob cath = do
|
|||
superUser #> "@SimpleX-Directory /last"
|
||||
superUser <# "SimpleX-Directory> > /last"
|
||||
superUser <## " 3 registered group(s)"
|
||||
superUser <# "SimpleX-Directory> 1. privacy (Privacy)"
|
||||
superUser <## "Welcome message:"
|
||||
superUser <##. "Link to join the group privacy: "
|
||||
superUser <## "Owner: bob"
|
||||
superUser <## "3 members"
|
||||
superUser <## "Status: active"
|
||||
superUser <# "SimpleX-Directory> 2. security (Security)"
|
||||
superUser <## "Welcome message:"
|
||||
superUser <##. "Link to join the group security: "
|
||||
superUser <## "Owner: bob"
|
||||
superUser <## "2 members"
|
||||
superUser <## "Status: active"
|
||||
superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
|
||||
superUser <## "Welcome message:"
|
||||
superUser <##. "Link to join the group anonymity: "
|
||||
superUser <## "Owner: cath"
|
||||
superUser <## "2 members"
|
||||
superUser <## "Status: suspended because roles changed"
|
||||
memberGroupListing superUser bob 1 "privacy" "Privacy" 3 "active"
|
||||
memberGroupListing superUser bob 2 "security" "Security" 2 "active"
|
||||
memberGroupListing superUser cath 3 "anonymity" "Anonymity" 2 "suspended because roles changed"
|
||||
-- showing last 1 group
|
||||
superUser #> "@SimpleX-Directory /last 1"
|
||||
superUser <# "SimpleX-Directory> > /last 1"
|
||||
superUser <## " 3 registered group(s), showing the last 1"
|
||||
superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
|
||||
superUser <## "Welcome message:"
|
||||
superUser <##. "Link to join the group anonymity: "
|
||||
superUser <## "Owner: cath"
|
||||
superUser <## "2 members"
|
||||
superUser <## "Status: suspended because roles changed"
|
||||
memberGroupListing superUser cath 3 "anonymity" "Anonymity" 2 "suspended because roles changed"
|
||||
|
||||
listUserGroup :: HasCallStack => TestCC -> String -> String -> IO ()
|
||||
listUserGroup u n fn = do
|
||||
sendListCommand u 1
|
||||
groupListing u 1 n fn 2 "active"
|
||||
|
||||
sendListCommand :: HasCallStack => TestCC -> Int -> IO ()
|
||||
sendListCommand u count = do
|
||||
u #> "@SimpleX-Directory /list"
|
||||
u <# "SimpleX-Directory> > /list"
|
||||
u <## (" " <> show count <> " registered group(s)")
|
||||
|
||||
groupListing :: HasCallStack => TestCC -> Int -> String -> String -> Int -> String -> IO ()
|
||||
groupListing u = groupListing_ u Nothing
|
||||
|
||||
memberGroupListing :: HasCallStack => TestCC -> TestCC -> Int -> String -> String -> Int -> String -> IO ()
|
||||
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)
|
||||
su <## (show count <> " members")
|
||||
su <## ("Status: " <> status)
|
||||
|
||||
reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO ()
|
||||
reapproveGroup count superUser bob = do
|
||||
|
|
@ -1146,10 +1226,13 @@ 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!"
|
||||
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 <## "Use /filter 1 to configure anti-spam filter and /role 1 to set default member role."
|
||||
bob <## "Supported commands:"
|
||||
bob <## "- /filter 1 - to configure anti-spam filter."
|
||||
bob <## "- /role 1 - to set default member role."
|
||||
bob <## "- /help commands - other commands."
|
||||
|
||||
addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
addCathAsOwner bob cath = do
|
||||
|
|
@ -1293,10 +1376,13 @@ approveRegistrationId su u n gId ugId = do
|
|||
su #> ("@SimpleX-Directory " <> approve)
|
||||
su <# ("SimpleX-Directory> > " <> approve)
|
||||
su <## " Group approved!"
|
||||
u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory!")
|
||||
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 <## ""
|
||||
u <## ("Use /filter " <> show ugId <> " to configure anti-spam filter and /role " <> show ugId <> " to set default member role.")
|
||||
u <## "Supported commands:"
|
||||
u <## ("- /filter " <> show ugId <> " - to configure anti-spam filter.")
|
||||
u <## ("- /role " <> show ugId <> " - to set default member role.")
|
||||
u <## "- /help commands - other commands."
|
||||
|
||||
connectVia :: TestCC -> String -> IO ()
|
||||
u `connectVia` dsLink = do
|
||||
|
|
|
|||
|
|
@ -8,7 +8,9 @@ module MarkdownTests where
|
|||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import System.Console.ANSI.Types
|
||||
import Test.Hspec
|
||||
|
||||
|
|
@ -169,7 +171,12 @@ uri :: Text -> Markdown
|
|||
uri = Markdown $ Just Uri
|
||||
|
||||
simplexLink :: SimplexLinkType -> Text -> NonEmpty Text -> Text -> Markdown
|
||||
simplexLink linkType simplexUri smpHosts = Markdown $ Just SimplexLink {linkType, simplexUri, smpHosts}
|
||||
simplexLink linkType uriText smpHosts t = Markdown (simplexLinkFormat linkType uriText smpHosts) t
|
||||
|
||||
simplexLinkFormat :: SimplexLinkType -> Text -> NonEmpty Text -> Maybe Format
|
||||
simplexLinkFormat linkType uriText smpHosts = case strDecode $ encodeUtf8 uriText of
|
||||
Right simplexUri -> Just SimplexLink {linkType, simplexUri, smpHosts}
|
||||
Left e -> error e
|
||||
|
||||
textWithUri :: Spec
|
||||
textWithUri = describe "text with Uri" do
|
||||
|
|
@ -275,6 +282,6 @@ multilineMarkdownList = describe "multiline markdown" do
|
|||
it "multiline with simplex link" do
|
||||
("https://simplex.chat" <> inv <> "\ntext")
|
||||
<<==>>
|
||||
[ FormattedText (Just $ SimplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"]) ("https://simplex.chat" <> inv),
|
||||
[ FormattedText (simplexLinkFormat XLInvitation ("simplex:" <> inv) ["smp.simplex.im"]) ("https://simplex.chat" <> inv),
|
||||
"\ntext"
|
||||
]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue