IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

directory: list groups with group member counts (#2855)

Browse Source 
* directory: list groups with group member counts

* list groups, test

* superuser can list all groups

* rename command

* remove type synonym

* add member count to search results

* fix test
This commit is contained in:
Evgeny Poberezkin 2023-08-06 11:56:40 +01:00 committed by GitHub
parent 8f72328136
commit 4826a62d36
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 357 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
apps/simplex-directory-service/src/Directory/Events.hs
View File

@ -81,7 +81,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser
DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
DCListGroups_ :: DirectoryCmdTag 'DRSuperUser
DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
@ -97,7 +97,7 @@ data DirectoryCmd (r :: DirectoryRole) where
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCListGroups :: DirectoryCmd 'DRSuperUser
DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@ -105,7 +105,7 @@ deriving instance Show (DirectoryCmd r)
data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r)
deriving instance Show (ADirectoryCmd)
deriving instance Show ADirectoryCmd
directoryCmdP :: Parser ADirectoryCmd
directoryCmdP =
@ -124,7 +124,7 @@ directoryCmdP =
"reject" -> su DCRejectGroup_
"suspend" -> su DCSuspendGroup_
"resume" -> su DCResumeGroup_
"all" -> su DCListGroups_
"last" -> su DCListLastGroups_
_ -> fail "bad command tag"
where
u = pure . ADCT SDRUser
@ -142,6 +142,6 @@ directoryCmdP =
DCRejectGroup_ -> gc DCRejectGroup
DCSuspendGroup_ -> gc DCSuspendGroup
DCResumeGroup_ -> gc DCResumeGroup
DCListGroups_ -> pure DCListGroups
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ')

129
apps/simplex-directory-service/src/Directory/Service.hs
View File

@ -17,7 +17,7 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
@ -100,12 +100,14 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d
groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} =
"ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName
userGroupReference' GroupReg {userGroupRegId} displayName = groupReference' userGroupRegId displayName
groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = groupReference' groupId displayName
groupReference' groupId displayName = "ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} =
T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name."
getGroups :: Text -> IO (Maybe [GroupInfo])
getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)])
getGroups search =
sendChatCmd cc (APIListGroups userId Nothing $ Just $ T.unpack search) >>= \case
CRGroupsList {groups} -> pure $ Just groups
@ -115,7 +117,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} =
getGroups fullName >>= mapM duplicateGroup
where
sameGroup GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}} =
sameGroup (GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) =
gId /= groupId && n == displayName && fn == fullName
duplicateGroup [] = pure DGUnique
duplicateGroup groups = do
@ -124,12 +126,12 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
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
let reserved = any (\(GroupInfo {groupId = gId}, _) -> gId `S.member` lgs || gId `S.member` rgs) gs
pure $ if reserved then DGReserved else DGRegistered
processInvitation :: Contact -> GroupInfo -> IO ()
processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do
atomically $ addGroupReg st ct g GRSProposed
void $ atomically $ addGroupReg st ct g GRSProposed
r <- sendChatCmd cc $ APIJoinGroup groupId
sendMessage cc ct $ T.unpack $ case r of
CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…"
@ -144,7 +146,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
\For example, send _privacy_ to find groups about privacy."
deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO ()
deGroupInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} fromMemberRole memberRole = do
deGroupInvitation ct g@GroupInfo {groupProfile = GroupProfile {displayName, fullName}} fromMemberRole memberRole = do
case badRolesMsg $ groupRolesStatus fromMemberRole memberRole of
Just msg -> sendMessage cc ct msg
Nothing -> getDuplicateGroup g >>= \case
@ -154,9 +156,9 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers."
where
askConfirmation = do
atomically $ addGroupReg st ct g GRSPendingConfirmation
ugrId <- atomically $ addGroupReg st ct g GRSPendingConfirmation
sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
sendMessage cc ct $ "/confirm " <> show groupId <> ":" <> T.unpack displayName
sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> T.unpack displayName
badRolesMsg :: GroupRolesStatus -> Maybe String
badRolesMsg = \case
@ -215,20 +217,21 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
unless (sameProfile p p') $ do
atomically $ unlistGroup st groupId
withGroupReg toGroup "group updated" $ \gr -> do
let userGroupRef = userGroupReference gr toGroup
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingConfirmation -> pure ()
GRSProposed -> pure ()
GRSPendingUpdate -> groupProfileUpdate >>= \case
GPNoServiceLink ->
when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> groupRef <> ", but the group link is not added to the welcome message."
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 " <> groupRef <> " is removed from the welcome message, please add it."
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
GPServiceLinkError -> do
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> groupRef <> ". Please report the error to the developers."
putStrLn $ "Error: no group link for " <> groupRef
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers."
putStrLn $ "Error: no group link for " <> userGroupRef
GRSPendingApproval n -> processProfileChange gr $ n + 1
GRSActive -> processProfileChange gr 1
GRSSuspended -> processProfileChange gr 1
@ -238,7 +241,6 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_
GroupInfo {groupId, groupProfile = p} = fromGroup
GroupInfo {groupProfile = p'} = toGroup
groupRef = groupReference toGroup
sameProfile
GroupProfile {displayName = n, fullName = fn, image = i, description = d}
GroupProfile {displayName = n', fullName = fn', image = i', description = d'} =
@ -248,26 +250,29 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
Nothing -> notifyOwner gr "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup
_ -> do
notifyOwner gr $ "Thank you! The group link for " <> groupRef <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
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 24 hours."
let gaId = 1
setGroupStatus gr $ GRSPendingApproval gaId
checkRolesSendToApprove gr gaId
processProfileChange gr n' = groupProfileUpdate >>= \case
processProfileChange gr n' = do
let userGroupRef = userGroupReference gr toGroup
groupRef = groupReference toGroup
groupProfileUpdate >>= \case
GPNoServiceLink -> do
setGroupStatus gr GRSPendingUpdate
notifyOwner gr $ "The group profile is updated " <> groupRef <> ", 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 " <> 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."
GPServiceLinkRemoved -> do
setGroupStatus gr GRSPendingUpdate
notifyOwner gr $ "The group link for " <> groupRef <> " 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.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
notifySuperUsers $ "The group link is removed from " <> groupRef <> ", de-listed."
GPServiceLinkAdded -> do
setGroupStatus gr $ GRSPendingApproval n'
notifyOwner gr $ "The group link is added to " <> groupRef <> "!\nIt is hidden from the directory until approved."
notifyOwner gr $ "The group link is added to " <> userGroupRef <> "!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group link is added to " <> groupRef <> "."
checkRolesSendToApprove gr n'
GPHasServiceLink -> do
setGroupStatus gr $ GRSPendingApproval n'
notifyOwner gr $ "The group " <> groupRef <> " is updated!\nIt is hidden from the directory until approved."
notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group " <> groupRef <> " is updated."
checkRolesSendToApprove gr n'
GPServiceLinkError -> putStrLn $ "Error: no group link for " <> groupRef <> " pending approval."
@ -302,7 +307,9 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO ()
deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole =
withGroupReg g "contact role changed" $ \gr ->
withGroupReg g "contact role changed" $ \gr -> do
let userGroupRef = userGroupReference gr g
uCtRole = "Your role in the group " <> userGroupRef <> " is changed to " <> ctRole
when (ctId `isOwner` gr) $ do
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do
@ -321,12 +328,13 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
rStatus = groupRolesStatus contactRole serviceRole
groupRef = groupReference g
ctRole = "*" <> B.unpack (strEncode contactRole) <> "*"
uCtRole = "Your role in the group " <> groupRef <> " is changed to " <> ctRole
suCtRole = "(user role is set to " <> ctRole <> ")."
deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO ()
deServiceRoleChanged g serviceRole = do
withGroupReg g "service role changed" $ \gr -> do
let userGroupRef = userGroupReference gr g
uSrvRole = serviceName <> " role in the group " <> userGroupRef <> " is changed to " <> srvRole
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $
whenContactIsOwner gr $ do
@ -345,7 +353,6 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
where
groupRef = groupReference g
srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*"
uSrvRole = serviceName <> " role in the group " <> groupRef <> " is changed to " <> srvRole
suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")."
whenContactIsOwner gr action =
getGroupMember gr >>=
@ -356,26 +363,23 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
withGroupReg g "contact removed" $ \gr -> do
when (ctId `isOwner` gr) $ do
setGroupStatus gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ "You are removed from the group " <> groupRef <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner is removed)."
notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)."
deContactLeftGroup :: ContactId -> GroupInfo -> IO ()
deContactLeftGroup ctId g =
withGroupReg g "contact left" $ \gr -> do
when (ctId `isOwner` gr) $ do
setGroupStatus gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ "You left the group " <> groupRef <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner left)."
notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)."
deServiceRemovedFromGroup :: GroupInfo -> IO ()
deServiceRemovedFromGroup g =
withGroupReg g "service removed" $ \gr -> do
setGroupStatus gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ serviceName <> " is removed from the group " <> groupRef <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (directory service is removed)."
notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)."
deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO ()
deUserCommand ct ciId = \case
@ -394,13 +398,15 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
[] -> sendReply "No groups found"
gs -> do
sendReply $ "Found " <> show (length gs) <> " group(s)"
void . forkIO $ forM_ gs $ \GroupInfo {groupProfile = p@GroupProfile {image = image_}} -> do
let text = groupInfoText p
void . forkIO $ forM_ gs $
\(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = tshow currentMembers <> " members"
text = groupInfoText p <> "\n" <> membersStr
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
Nothing -> sendReply "Error: getGroups. Please notify the developers."
DCConfirmDuplicateGroup ugrId gName ->
atomically (getGroupReg st ugrId) >>= \case
atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case
Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found"
Just GroupReg {dbGroupId, groupRegStatus} -> do
getGroup cc dbGroupId >>= \case
@ -415,7 +421,11 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
_ -> processInvitation ct g
_ -> sendReply $ "Error: the group ID " <> show ugrId <> " (" <> T.unpack displayName <> ") is not pending confirmation."
| otherwise -> sendReply $ "Group ID " <> show ugrId <> " has the display name " <> T.unpack displayName
DCListUserGroups -> pure ()
DCListUserGroups ->
atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do
sendReply $ show (length grs) <> " registered group(s)"
void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
sendGroupInfo ct gr userGroupRegId Nothing
DCDeleteGroup _ugrId _gName -> pure ()
DCUnknownCommand -> sendReply "Unknown command"
DCCommandError tag -> sendReply $ "Command error: " <> show tag
@ -440,7 +450,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
Just GRSOk -> do
setGroupStatus gr GRSActive
sendReply "Group approved!"
notifyOwner gr $ "The group " <> groupRef <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
notifyOwner gr $ "The group " <> userGroupReference' gr n <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
@ -451,31 +461,37 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
where
groupRef = "ID " <> show groupId <> " (" <> T.unpack n <> ")"
groupRef = groupReference' groupId n
DCRejectGroup _gaId _gName -> pure ()
DCSuspendGroup groupId gName -> do
let groupRef = "ID " <> show groupId <> " (" <> T.unpack gName <> ")"
let groupRef = groupReference' groupId gName
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus gr GRSSuspended
notifyOwner gr $ "The group " <> groupRef <> " is suspended and hidden from directory. Please contact the administrators."
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators."
sendReply "Group suspended!"
_ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
DCResumeGroup groupId gName -> do
let groupRef = "ID " <> show groupId <> " (" <> T.unpack gName <> ")"
let groupRef = groupReference' groupId gName
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus gr GRSActive
notifyOwner gr $ "The group " <> groupRef <> " is listed in the directory again!"
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!"
sendReply "Group listing resumed!"
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
DCListGroups -> pure ()
DCListLastGroups count ->
readTVarIO (groupRegs st) >>= \grs -> do
sendReply $ show (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> show count else "")
void . forkIO $ forM_ (reverse $ take count grs) $ \gr@GroupReg {dbGroupId, dbContactId} -> do
ct_ <- getContact cc dbContactId
let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_
sendGroupInfo ct gr dbGroupId $ Just ownerStr
DCCommandError tag -> sendReply $ "Command error: " <> show tag
| otherwise = sendReply "You are not allowed to use this command"
where
@ -491,6 +507,20 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
$>>= \gr -> pure $ Just (g, gr)
else pure Nothing
sendGroupInfo :: Contact -> GroupReg -> GroupId -> Maybe Text -> IO ()
sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do
grStatus <- readTVarIO $ groupRegStatus gr
let statusStr = "Status: " <> groupRegStatusText grStatus
getGroupAndSummary cc dbGroupId >>= \case
Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = tshow currentMembers <> " members"
text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr]
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
Nothing -> do
let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr]
sendComposedMessage cc ct Nothing $ MCText text
getContact :: ChatController -> ContactId -> IO (Maybe Contact)
getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) (CPLast 0) Nothing)
where
@ -500,11 +530,18 @@ getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId)
_ -> Nothing
getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo)
getGroup cc gId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTGroup gId) (CPLast 0) Nothing)
getGroup cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId)
where
resp :: ChatResponse -> Maybe GroupInfo
resp = \case
CRApiChat _ (AChat SCTGroup Chat {chatInfo = GroupChat g}) -> Just g
CRGroupInfo {groupInfo} -> Just groupInfo
_ -> Nothing
getGroupAndSummary :: ChatController -> GroupId -> IO (Maybe (GroupInfo, GroupSummary))
getGroupAndSummary cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId)
where
resp = \case
CRGroupInfo {groupInfo, groupSummary} -> Just (groupInfo, groupSummary)
_ -> Nothing
unexpectedError :: String -> String

47
apps/simplex-directory-service/src/Directory/Store.hs
View File

@ -1,13 +1,16 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Directory.Store where
import Control.Concurrent.STM
import Data.Int (Int64)
import Data.Set (Set)
import Data.Text (Text)
import Simplex.Chat.Types
import Data.List (find)
import Data.List (find, foldl')
import qualified Data.Set as S
data DirectoryStore = DirectoryStore
@ -24,8 +27,6 @@ data GroupReg = GroupReg
groupRegStatus :: TVar GroupRegStatus
}
type GroupRegId = Int64
type UserGroupRegId = Int64
type GroupApprovalId = Int64
@ -40,26 +41,44 @@ data GroupRegStatus
| GRSSuspendedBadRoles
| GRSRemoved
addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> STM ()
groupRegStatusText :: GroupRegStatus -> Text
groupRegStatusText = \case
GRSPendingConfirmation -> "pending confirmation (duplicate names)"
GRSProposed -> "proposed"
GRSPendingUpdate -> "pending profile update"
GRSPendingApproval _ -> "pending admin approval"
GRSActive -> "active"
GRSSuspended -> "suspended by admin"
GRSSuspendedBadRoles -> "suspended because roles changed"
GRSRemoved -> "removed"
addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> STM UserGroupRegId
addGroupReg st ct GroupInfo {groupId} grStatus = do
dbOwnerMemberId <- newTVar Nothing
groupRegStatus <- newTVar grStatus
let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, dbOwnerMemberId, groupRegStatus}
modifyTVar' (groupRegs st) (gr :)
let gr = GroupReg {userGroupRegId = 1, dbGroupId = groupId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus}
stateTVar (groupRegs st) $ \grs ->
let ugrId = 1 + foldl' maxUgrId 0 grs
in (ugrId, gr {userGroupRegId = ugrId} : grs)
where
ctId = contactId' ct
maxUgrId mx GroupReg {dbContactId, userGroupRegId}
| dbContactId == ctId && userGroupRegId > mx = userGroupRegId
| otherwise = mx
getGroupReg :: DirectoryStore -> GroupRegId -> STM (Maybe GroupReg)
getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg)
getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
getUserGroupRegId :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
getUserGroupRegId st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
getContactGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
getContactGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
filterListedGroups :: DirectoryStore -> [GroupInfo] -> STM [GroupInfo]
filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> STM [(GroupInfo, GroupSummary)]
filterListedGroups st gs = do
lgs <- readTVar $ listedGroups st
pure $ filter (\GroupInfo {groupId} -> groupId `S.member` lgs) gs
pure $ filter (\(GroupInfo {groupId}, _) -> groupId `S.member` lgs) gs
listGroup :: DirectoryStore -> GroupId -> STM ()
listGroup st gId = do
@ -78,7 +97,7 @@ unlistGroup st gId = do
data DirectoryLogRecord
= CreateGroupReg GroupReg
| UpdateGroupRegStatus GroupRegId GroupRegStatus
| UpdateGroupRegStatus GroupId GroupRegStatus
getDirectoryStore :: FilePath -> IO DirectoryStore
getDirectoryStore path = do

10
src/Simplex/Chat.hs
View File

@ -1144,6 +1144,9 @@ processChatCommand = \case
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
connectionStats <- withAgent (`getConnectionServers` contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId)
pure $ CRGroupInfo user g s
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
@ -1230,6 +1233,9 @@ processChatCommand = \case
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
ContactInfo cName -> withContactName cName APIContactInfo
ShowGroupInfo gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIGroupInfo groupId
GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo
SwitchContact cName -> withContactName cName APISwitchContact
SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember
@ -1493,7 +1499,7 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
CRGroupsList user <$> withStore' (\db -> getUserGroupDetails db user contactId_ search_)
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db user contactId_ search_)
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
@ -5092,8 +5098,10 @@ chatCommandP =
"/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
"/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
"/_info #" *> (APIGroupInfo <$> A.decimal),
"/_info @" *> (APIContactInfo <$> A.decimal),
("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName),
("/info #" <|> "/i #") *> (ShowGroupInfo <$> displayName),
("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName),
"/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal),
"/_switch @" *> (APISwitchContact <$> A.decimal),

5
src/Simplex/Chat/Controller.hs
View File

@ -291,6 +291,7 @@ data ChatCommand
| ReconnectAllServers
| APISetChatSettings ChatRef ChatSettings
| APIContactInfo ContactId
| APIGroupInfo GroupId
| APIGroupMemberInfo GroupId GroupMemberId
| APISwitchContact ContactId
| APISwitchGroupMember GroupId GroupMemberId
@ -307,6 +308,7 @@ data ChatCommand
| SetShowMessages ChatName Bool
| SetSendReceipts ChatName (Maybe Bool)
| ContactInfo ContactName
| ShowGroupInfo GroupName
| GroupMemberInfo GroupName ContactName
| SwitchContact ContactName
| SwitchGroupMember GroupName ContactName
@ -424,6 +426,7 @@ data ChatResponse
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
| CRNetworkConfig {networkConfig :: NetworkConfig}
| CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile}
| CRGroupInfo {user :: User, groupInfo :: GroupInfo, groupSummary :: GroupSummary}
| CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
| CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats}
| CRGroupMemberSwitchStarted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats}
@ -461,7 +464,7 @@ data ChatResponse
| CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest}
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
| CRUserDeletedMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRGroupsList {user :: User, groups :: [GroupInfo]}
| CRGroupsList {user :: User, groups :: [(GroupInfo, GroupSummary)]}
| CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember}
| CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
| CRFileTransferStatusXFTP User AChatItem

26
src/Simplex/Chat/Store/Groups.hs
View File

@ -45,6 +45,8 @@ module Simplex.Chat.Store.Groups
deleteGroup,
getUserGroups,
getUserGroupDetails,
getUserGroupsWithSummary,
getGroupSummary,
getContactGroupPreferences,
checkContactHasGroups,
getGroupInvitation,
@ -468,6 +470,30 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where
search = fromMaybe "" search_
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db user _contactId_ search_ =
getUserGroupDetails db user _contactId_ search_
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
-- the statuses on non-current members should match memberCurrent' function
getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
getGroupSummary db User {userId} groupId = do
currentMembers_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT count (m.group_member_id)
FROM groups g
JOIN group_members m USING (group_id)
WHERE g.user_id = ?
AND g.group_id = ?
AND m.member_status != ?
AND m.member_status != ?
AND m.member_status != ?
|]
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
getContactGroupPreferences db User {userId} Contact {contactId} = do
map (mergeGroupPreferences . fromOnly)

8
src/Simplex/Chat/Types.hs
View File

@ -318,6 +318,13 @@ instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOption
groupName' :: GroupInfo -> GroupName
groupName' GroupInfo {localDisplayName = g} = g
data GroupSummary = GroupSummary
{ currentMembers :: Int
}
deriving (Show, Generic)
instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions
data ContactOrGroup = CGContact Contact | CGGroup Group
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
@ -784,6 +791,7 @@ memberActive m = case memberStatus m of
memberCurrent :: GroupMember -> Bool
memberCurrent = memberCurrent' . memberStatus
-- update getGroupSummary if this is changed
memberCurrent' :: GroupMemberStatus -> Bool
memberCurrent' = \case
GSMemRemoved -> False

18
src/Simplex/Chat/View.hs
View File

@ -79,6 +79,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
CRNetworkConfig cfg -> viewNetworkConfig cfg
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
CRGroupInfo u g s -> ttyUser u $ viewGroupInfo g s
CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats
CRContactSwitchStarted {} -> ["switch started"]
CRGroupMemberSwitchStarted {} -> ["switch started"]
@ -811,12 +812,12 @@ viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView
Nothing ->
[ttyFullContact ct <> ": contact is connected"]
viewGroupsList :: [GroupInfo] -> [StyledString]
viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings} =
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst
groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) =
case memberStatus membership of
GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s
@ -826,9 +827,10 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs
GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted"
_
| enableNtfs chatSettings -> ""
| otherwise -> " (muted, you can " <> highlight ("/unmute #" <> ldn) <> ")"
| enableNtfs chatSettings -> " (" <> memberCount <> ")"
| otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> ldn) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> ldn) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
groupInvitation' :: GroupInfo -> StyledString
groupInvitation' GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership = membership@GroupMember {memberProfile}} =
@ -935,6 +937,12 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta
<> ["alias: " <> plain localAlias | localAlias /= ""]
<> [viewConnectionVerified (contactSecurityCode ct)]
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
viewGroupInfo GroupInfo {groupId} s =
[ "group ID: " <> sShow groupId,
"current members: " <> sShow (currentMembers s)
]
viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}} stats =
[ "group ID: " <> sShow groupId,

197
tests/Bots/DirectoryTests.hs
View File

@ -15,7 +15,7 @@ import Directory.Store
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Types (Profile (..), GroupMemberRole (GROwner))
import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
import System.FilePath ((</>))
import Test.Hspec
@ -45,6 +45,8 @@ directoryServiceTests = do
it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation
it "should prohibit when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated
it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval
describe "list groups" $ do
it "should list user's groups" testListUserGroups
directoryProfile :: Profile
directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
@ -139,6 +141,7 @@ testDirectoryService tmp =
u <# "SimpleX-Directory> PSA (Privacy, Security & Anonymity)"
u <## "Welcome message:"
u <## welcome
u <## "2 members"
updateGroupProfile u welcome = do
u ##> ("/set welcome #PSA " <> welcome)
u <## "description changed to:"
@ -172,7 +175,7 @@ testSuspendResume tmp =
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
testDelistedOwnerLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -203,7 +206,7 @@ testDelistedOwnerRemoved tmp =
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -216,7 +219,7 @@ testNotDelistedMemberLeaves tmp =
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -228,7 +231,7 @@ testNotDelistedMemberRemoved tmp =
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
testDelistedServiceRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -245,12 +248,12 @@ testDelistedServiceRemoved tmp =
testDelistedRoleChanges :: HasCallStack => FilePath -> IO ()
testDelistedRoleChanges tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
-- de-listed if service role changed
bob ##> "/mr privacy SimpleX-Directory member"
bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member"
@ -268,7 +271,7 @@ testDelistedRoleChanges tmp =
bob <## ""
bob <## "The group is listed in the directory again."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is listed (SimpleX-Directory role is changed to admin)."
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
-- de-listed if owner role changed
cath ##> "/mr privacy bob admin"
cath <## "#privacy: you changed the role of bob from owner to admin"
@ -286,26 +289,26 @@ testDelistedRoleChanges tmp =
bob <## ""
bob <## "The group is listed in the directory again."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is listed (user role is set to owner)."
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testNotDelistedMemberRoleChanged :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRoleChanged tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
bob ##> "/mr privacy cath member"
bob <## "#privacy: you changed the role of cath from owner to member"
cath <## "#privacy: bob changed your role from owner to member"
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testNotSentApprovalBadRoles :: HasCallStack => FilePath -> IO ()
testNotSentApprovalBadRoles tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
@ -328,7 +331,7 @@ testNotSentApprovalBadRoles tmp =
testNotApprovedBadRoles :: HasCallStack => FilePath -> IO ()
testNotApprovedBadRoles tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
@ -355,7 +358,7 @@ testNotApprovedBadRoles tmp =
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testRegOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -369,12 +372,12 @@ testRegOwnerChangedProfile tmp =
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testAnotherOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -388,12 +391,12 @@ testAnotherOwnerChangedProfile tmp =
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testRegOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -421,12 +424,12 @@ testRegOwnerRemovedLink tmp =
cath <## "description changed to:"
cath <## welcomeWithLink
reapproveGroup superUser bob
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testAnotherOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -463,12 +466,12 @@ testAnotherOwnerRemovedLink tmp =
cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!")
reapproveGroup superUser bob
groupFound cath "privacy"
groupFoundN 3 cath "privacy"
testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO ()
testDuplicateAskConfirmation tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy"
@ -477,8 +480,8 @@ testDuplicateAskConfirmation tmp =
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 2:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy"
cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink <- groupAccepted cath "privacy"
groupNotFound bob "privacy"
completeRegistration superUser cath "privacy" "Privacy" welcomeWithLink 2
@ -487,7 +490,7 @@ testDuplicateAskConfirmation tmp =
testDuplicateProhibitRegistration :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitRegistration tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -499,7 +502,7 @@ testDuplicateProhibitRegistration tmp =
testDuplicateProhibitConfirmation :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitConfirmation tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy"
@ -508,17 +511,17 @@ testDuplicateProhibitConfirmation tmp =
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 2:privacy"
cath <# "SimpleX-Directory> /confirm 1:privacy"
groupNotFound cath "privacy"
completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1
groupFound cath "privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy"
cath #> "@SimpleX-Directory /confirm 1:privacy"
cath <# "SimpleX-Directory> The group privacy (Privacy) is already listed in the directory, please choose another name."
testDuplicateProhibitWhenUpdated :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitWhenUpdated tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy"
@ -527,8 +530,8 @@ testDuplicateProhibitWhenUpdated tmp =
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 2:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy"
cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink' <- groupAccepted cath "privacy"
groupNotFound cath "privacy"
completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1
@ -549,7 +552,7 @@ testDuplicateProhibitWhenUpdated tmp =
testDuplicateProhibitApproval :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitApproval tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy"
@ -558,8 +561,8 @@ testDuplicateProhibitApproval tmp =
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 2:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy"
cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink' <- groupAccepted cath "privacy"
updateProfileWithLink cath "privacy" welcomeWithLink' 2
notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2
@ -572,6 +575,93 @@ testDuplicateProhibitApproval tmp =
superUser <# ("SimpleX-Directory> > " <> approve)
superUser <## " The group ID 2 (privacy) is already listed in the directory."
testListUserGroups :: HasCallStack => FilePath -> IO ()
testListUserGroups tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
connectUsers bob cath
fullAddMember "privacy" "Privacy" bob cath GRMember
joinGroup "privacy" cath bob
cath <## "#privacy: member SimpleX-Directory_1 is connected"
cath <## "contact SimpleX-Directory_1 is merged into SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
registerGroupId superUser bob "security" "Security" 2 2
registerGroupId superUser cath "anonymity" "Anonymity" 3 1
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: active"
-- with de-listed group
groupFound cath "anonymity"
cath ##> "/mr anonymity SimpleX-Directory member"
cath <## "#anonymity: you changed the role of SimpleX-Directory from admin to member"
cath <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (anonymity) is changed to member."
cath <## ""
cath <## "The group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 3 (anonymity) is de-listed (SimpleX-Directory role is changed to member)."
groupNotFound cath "anonymity"
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"
-- superuser lists all groups
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"
-- 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"
reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO ()
reapproveGroup superUser bob = do
superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy ("
@ -617,10 +707,13 @@ withDirectoryService tmp test = do
bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
registerGroup su u n fn = do
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
completeRegistration su u n fn welcomeWithLink 1
completeRegistrationId su u n fn welcomeWithLink gId ugId
submitGroup :: TestCC -> String -> String -> IO ()
submitGroup u n fn = do
@ -642,17 +735,21 @@ groupAccepted u n = do
dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u -- welcome message with link
completeRegistration :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
completeRegistration su u n fn welcomeWithLink gId = do
updateProfileWithLink u n welcomeWithLink gId
completeRegistration su u n fn welcomeWithLink gId =
completeRegistrationId su u n fn welcomeWithLink gId gId
completeRegistrationId :: TestCC -> TestCC -> String -> String -> String -> Int -> Int -> IO ()
completeRegistrationId su u n fn welcomeWithLink gId ugId = do
updateProfileWithLink u n welcomeWithLink ugId
notifySuperUser su u n fn welcomeWithLink gId
approveRegistration su u n gId
approveRegistrationId su u n gId ugId
updateProfileWithLink :: TestCC -> String -> String -> Int -> IO ()
updateProfileWithLink u n welcomeWithLink gId = do
updateProfileWithLink u n welcomeWithLink ugId = do
u ##> ("/set welcome " <> n <> " " <> welcomeWithLink)
u <## "description changed to:"
u <## welcomeWithLink
u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show gId <> " (" <> n <> ") is added to the welcome message.")
u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.")
u <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
@ -667,12 +764,16 @@ notifySuperUser su u n fn welcomeWithLink gId = do
su <# ("SimpleX-Directory> " <> approve)
approveRegistration :: TestCC -> TestCC -> String -> Int -> IO ()
approveRegistration su u n gId = do
approveRegistration su u n gId =
approveRegistrationId su u n gId gId
approveRegistrationId :: TestCC -> TestCC -> String -> Int -> Int -> IO ()
approveRegistrationId su u n gId ugId = do
let approve = "/approve " <> show gId <> ":" <> n <> " 1"
su #> ("@SimpleX-Directory " <> approve)
su <# ("SimpleX-Directory> > " <> approve)
su <## " Group approved!"
u <# ("SimpleX-Directory> The group ID " <> show gId <> " (" <> n <> ") is approved and listed in directory!")
u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory!")
u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
connectVia :: TestCC -> String -> IO ()
@ -713,13 +814,17 @@ removeMember gName admin removed = do
removed <## ("use /d " <> gn <> " to delete the group")
groupFound :: TestCC -> String -> IO ()
groupFound u name = do
groupFound = groupFoundN 2
groupFoundN :: Int -> TestCC -> String -> IO ()
groupFoundN count u name = do
u #> ("@SimpleX-Directory " <> name)
u <# ("SimpleX-Directory> > " <> name)
u <## " Found 1 group(s)"
u <#. ("SimpleX-Directory> " <> name <> " (")
u <## "Welcome message:"
u <##. "Link to join the group privacy: "
u <##. "Link to join the group "
u <## (show count <> " members")
groupNotFound :: TestCC -> String -> IO ()
groupNotFound u s = do

4
tests/ChatTests/Direct.hs
View File

@ -990,7 +990,7 @@ testMuteGroup =
(bob </)
(cath <# "#team alice> hi")
bob ##> "/gs"
bob <## "#team (muted, you can /unmute #team)"
bob <## "#team (3 members, muted, you can /unmute #team)"
bob ##> "/unmute #team"
bob <## "ok"
alice #> "#team hi again"
@ -998,7 +998,7 @@ testMuteGroup =
(bob <# "#team alice> hi again")
(cath <# "#team alice> hi again")
bob ##> "/gs"
bob <## "#team"
bob <## "#team (3 members)"
testCreateSecondUser :: HasCallStack => FilePath -> IO ()
testCreateSecondUser =

8
tests/ChatTests/Groups.hs
View File

@ -132,7 +132,7 @@ testGroupShared alice bob cath checkMessages = do
when checkMessages $ getReadChats msgItem1 msgItem2
-- list groups
alice ##> "/gs"
alice <## "#team"
alice <## "#team (3 members)"
-- list group members
alice ##> "/ms team"
alice
@ -739,18 +739,18 @@ testGroupList =
]
-- alice sees both groups
alice ##> "/gs"
alice <### ["#team", "#tennis"]
alice <### ["#team (2 members)", "#tennis (1 member)"]
-- bob sees #tennis as invitation
bob ##> "/gs"
bob
<### [ "#team",
<### [ "#team (2 members)",
"#tennis - you are invited (/j tennis to join, /d #tennis to delete invitation)"
]
-- after deleting invitation bob sees only one group
bob ##> "/d #tennis"
bob <## "#tennis: you deleted the group"
bob ##> "/gs"
bob <## "#team"
bob <## "#team (2 members)"
testGroupMessageQuotedReply :: HasCallStack => FilePath -> IO ()
testGroupMessageQuotedReply =

2
tests/ChatTests/Profiles.hs
View File

@ -770,7 +770,7 @@ testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfil
dan <##> cath
-- list groups
cath ##> "/gs"
cath <## "i #secret_club"
cath <## "i #secret_club (4 members)"
-- list group members
alice ##> "/ms secret_club"
alice

3
tests/ChatTests/Utils.hs
View File

@ -470,6 +470,7 @@ createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
createGroup3 gName cc1 cc2 cc3 = do
createGroup2 gName cc1 cc2
connectUsers cc1 cc3
name1 <- userName cc1
name3 <- userName cc3
sName2 <- showName cc2
sName3 <- showName cc3
@ -481,7 +482,7 @@ createGroup3 gName cc1 cc2 cc3 = do
cc3 <## ("#" <> gName <> ": you joined the group")
cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"),
do
cc2 <## ("#" <> gName <> ": alice added " <> sName3 <> " to the group (connecting...)")
cc2 <## ("#" <> gName <> ": " <> name1 <> " added " <> sName3 <> " to the group (connecting...)")
cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected")
]