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

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

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

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

@ -1,13 +1,16 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Directory.Store where module Directory.Store where
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.Int (Int64) import Data.Int (Int64)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text)
import Simplex.Chat.Types import Simplex.Chat.Types
import Data.List (find) import Data.List (find, foldl')
import qualified Data.Set as S import qualified Data.Set as S
data DirectoryStore = DirectoryStore data DirectoryStore = DirectoryStore
@ -24,8 +27,6 @@ data GroupReg = GroupReg
groupRegStatus :: TVar GroupRegStatus groupRegStatus :: TVar GroupRegStatus
} }
type GroupRegId = Int64
type UserGroupRegId = Int64 type UserGroupRegId = Int64
type GroupApprovalId = Int64 type GroupApprovalId = Int64
@ -40,26 +41,44 @@ data GroupRegStatus
| GRSSuspendedBadRoles | GRSSuspendedBadRoles
| GRSRemoved | 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 addGroupReg st ct GroupInfo {groupId} grStatus = do
dbOwnerMemberId <- newTVar Nothing dbOwnerMemberId <- newTVar Nothing
groupRegStatus <- newTVar grStatus groupRegStatus <- newTVar grStatus
let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, dbOwnerMemberId, groupRegStatus} let gr = GroupReg {userGroupRegId = 1, dbGroupId = groupId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus}
modifyTVar' (groupRegs st) (gr :) 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) getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
getUserGroupRegId :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg) getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
getUserGroupRegId st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st) getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
getContactGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg] getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
getContactGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st) 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 filterListedGroups st gs = do
lgs <- readTVar $ listedGroups st 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 :: DirectoryStore -> GroupId -> STM ()
listGroup st gId = do listGroup st gId = do
@ -78,7 +97,7 @@ unlistGroup st gId = do
data DirectoryLogRecord data DirectoryLogRecord
= CreateGroupReg GroupReg = CreateGroupReg GroupReg
| UpdateGroupRegStatus GroupRegId GroupRegStatus | UpdateGroupRegStatus GroupId GroupRegStatus
getDirectoryStore :: FilePath -> IO DirectoryStore getDirectoryStore :: FilePath -> IO DirectoryStore
getDirectoryStore path = do 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) incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
connectionStats <- withAgent (`getConnectionServers` contactConnId ct) connectionStats <- withAgent (`getConnectionServers` contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) 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 APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
@ -1230,6 +1233,9 @@ processChatCommand = \case
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn}) SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_}) SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
ContactInfo cName -> withContactName cName APIContactInfo 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 GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo
SwitchContact cName -> withContactName cName APISwitchContact SwitchContact cName -> withContactName cName APISwitchContact
SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember
@ -1493,7 +1499,7 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> 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 ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
@ -5092,8 +5098,10 @@ chatCommandP =
"/reconnect" $> ReconnectAllServers, "/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP), "/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
"/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal), "/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
"/_info #" *> (APIGroupInfo <$> A.decimal),
"/_info @" *> (APIContactInfo <$> A.decimal), "/_info @" *> (APIContactInfo <$> A.decimal),
("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName), ("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName),
("/info #" <|> "/i #") *> (ShowGroupInfo <$> displayName),
("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName), ("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName),
"/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), "/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal),
"/_switch @" *> (APISwitchContact <$> A.decimal), "/_switch @" *> (APISwitchContact <$> A.decimal),

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

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

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

@ -45,6 +45,8 @@ module Simplex.Chat.Store.Groups
deleteGroup, deleteGroup,
getUserGroups, getUserGroups,
getUserGroupDetails, getUserGroupDetails,
getUserGroupsWithSummary,
getGroupSummary,
getContactGroupPreferences, getContactGroupPreferences,
checkContactHasGroups, checkContactHasGroups,
getGroupInvitation, getGroupInvitation,
@ -468,6 +470,30 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where where
search = fromMaybe "" search_ 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.Connection -> User -> Contact -> IO [FullGroupPreferences]
getContactGroupPreferences db User {userId} Contact {contactId} = do getContactGroupPreferences db User {userId} Contact {contactId} = do
map (mergeGroupPreferences . fromOnly) 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 -> GroupName
groupName' GroupInfo {localDisplayName = g} = g 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 data ContactOrGroup = CGContact Contact | CGGroup Group
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId) contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
@ -784,6 +791,7 @@ memberActive m = case memberStatus m of
memberCurrent :: GroupMember -> Bool memberCurrent :: GroupMember -> Bool
memberCurrent = memberCurrent' . memberStatus memberCurrent = memberCurrent' . memberStatus
-- update getGroupSummary if this is changed
memberCurrent' :: GroupMemberStatus -> Bool memberCurrent' :: GroupMemberStatus -> Bool
memberCurrent' = \case memberCurrent' = \case
GSMemRemoved -> False 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 CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
CRNetworkConfig cfg -> viewNetworkConfig cfg CRNetworkConfig cfg -> viewNetworkConfig cfg
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile 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 CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats
CRContactSwitchStarted {} -> ["switch started"] CRContactSwitchStarted {} -> ["switch started"]
CRGroupMemberSwitchStarted {} -> ["switch started"] CRGroupMemberSwitchStarted {} -> ["switch started"]
@ -811,12 +812,12 @@ viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView
Nothing -> Nothing ->
[ttyFullContact ct <> ": contact is connected"] [ttyFullContact ct <> ": contact is connected"]
viewGroupsList :: [GroupInfo] -> [StyledString] viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sortOn ldn_ gs viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where where
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst
groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings} = groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) =
case memberStatus membership of case memberStatus membership of
GSMemInvited -> groupInvitation' g GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s 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" GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted" GSMemGroupDeleted -> delete "group deleted"
_ _
| enableNtfs chatSettings -> "" | enableNtfs chatSettings -> " (" <> memberCount <> ")"
| otherwise -> " (muted, you can " <> highlight ("/unmute #" <> ldn) <> ")" | otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> ldn) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> 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 -> StyledString
groupInvitation' GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership = membership@GroupMember {memberProfile}} = 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 /= ""] <> ["alias: " <> plain localAlias | localAlias /= ""]
<> [viewConnectionVerified (contactSecurityCode ct)] <> [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 -> GroupMember -> Maybe ConnectionStats -> [StyledString]
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}} stats = viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}} stats =
[ "group ID: " <> sShow groupId, [ "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.Bot.KnownContacts
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Types (Profile (..), GroupMemberRole (GROwner)) import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
import System.FilePath ((</>)) import System.FilePath ((</>))
import Test.Hspec import Test.Hspec
@ -45,6 +45,8 @@ directoryServiceTests = do
it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation 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 when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated
it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval 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
directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing} 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 <# "SimpleX-Directory> PSA (Privacy, Security & Anonymity)"
u <## "Welcome message:" u <## "Welcome message:"
u <## welcome u <## welcome
u <## "2 members"
updateGroupProfile u welcome = do updateGroupProfile u welcome = do
u ##> ("/set welcome #PSA " <> welcome) u ##> ("/set welcome #PSA " <> welcome)
u <## "description changed to:" u <## "description changed to:"
@ -172,7 +175,7 @@ testSuspendResume tmp =
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO () testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
testDelistedOwnerLeaves tmp = testDelistedOwnerLeaves tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -203,7 +206,7 @@ testDelistedOwnerRemoved tmp =
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO () testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberLeaves tmp = testNotDelistedMemberLeaves tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -216,7 +219,7 @@ testNotDelistedMemberLeaves tmp =
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO () testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRemoved tmp = testNotDelistedMemberRemoved tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -228,7 +231,7 @@ testNotDelistedMemberRemoved tmp =
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO () testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
testDelistedServiceRemoved tmp = testDelistedServiceRemoved tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -245,12 +248,12 @@ testDelistedServiceRemoved tmp =
testDelistedRoleChanges :: HasCallStack => FilePath -> IO () testDelistedRoleChanges :: HasCallStack => FilePath -> IO ()
testDelistedRoleChanges tmp = testDelistedRoleChanges tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath addCathAsOwner bob cath
groupFound cath "privacy" groupFoundN 3 cath "privacy"
-- de-listed if service role changed -- de-listed if service role changed
bob ##> "/mr privacy SimpleX-Directory member" bob ##> "/mr privacy SimpleX-Directory member"
bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member"
@ -268,7 +271,7 @@ testDelistedRoleChanges tmp =
bob <## "" bob <## ""
bob <## "The group is listed in the directory again." 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)." 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 -- de-listed if owner role changed
cath ##> "/mr privacy bob admin" cath ##> "/mr privacy bob admin"
cath <## "#privacy: you changed the role of bob from owner to admin" cath <## "#privacy: you changed the role of bob from owner to admin"
@ -286,26 +289,26 @@ testDelistedRoleChanges tmp =
bob <## "" bob <## ""
bob <## "The group is listed in the directory again." 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)." 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 :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRoleChanged tmp = testNotDelistedMemberRoleChanged tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath addCathAsOwner bob cath
groupFound cath "privacy" groupFoundN 3 cath "privacy"
bob ##> "/mr privacy cath member" bob ##> "/mr privacy cath member"
bob <## "#privacy: you changed the role of cath from owner to member" bob <## "#privacy: you changed the role of cath from owner to member"
cath <## "#privacy: bob changed your role 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 :: HasCallStack => FilePath -> IO ()
testNotSentApprovalBadRoles tmp = testNotSentApprovalBadRoles tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
cath `connectVia` dsLink cath `connectVia` dsLink
@ -328,7 +331,7 @@ testNotSentApprovalBadRoles tmp =
testNotApprovedBadRoles :: HasCallStack => FilePath -> IO () testNotApprovedBadRoles :: HasCallStack => FilePath -> IO ()
testNotApprovedBadRoles tmp = testNotApprovedBadRoles tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
cath `connectVia` dsLink cath `connectVia` dsLink
@ -355,7 +358,7 @@ testNotApprovedBadRoles tmp =
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO () testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testRegOwnerChangedProfile tmp = testRegOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -369,12 +372,12 @@ testRegOwnerChangedProfile tmp =
groupNotFound cath "privacy" groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob reapproveGroup superUser bob
groupFound cath "privacy" groupFoundN 3 cath "privacy"
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO () testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testAnotherOwnerChangedProfile tmp = testAnotherOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -388,12 +391,12 @@ testAnotherOwnerChangedProfile tmp =
groupNotFound cath "privacy" groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob reapproveGroup superUser bob
groupFound cath "privacy" groupFoundN 3 cath "privacy"
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO () testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testRegOwnerRemovedLink tmp = testRegOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -421,12 +424,12 @@ testRegOwnerRemovedLink tmp =
cath <## "description changed to:" cath <## "description changed to:"
cath <## welcomeWithLink cath <## welcomeWithLink
reapproveGroup superUser bob reapproveGroup superUser bob
groupFound cath "privacy" groupFoundN 3 cath "privacy"
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO () testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testAnotherOwnerRemovedLink tmp = testAnotherOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -463,12 +466,12 @@ testAnotherOwnerRemovedLink tmp =
cath <## "description changed to:" cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!") cath <## (welcomeWithLink <> " - welcome!")
reapproveGroup superUser bob reapproveGroup superUser bob
groupFound cath "privacy" groupFoundN 3 cath "privacy"
testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO () testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO ()
testDuplicateAskConfirmation tmp = testDuplicateAskConfirmation tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy" submitGroup bob "privacy" "Privacy"
@ -477,8 +480,8 @@ testDuplicateAskConfirmation tmp =
submitGroup cath "privacy" "Privacy" submitGroup cath "privacy" "Privacy"
cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory."
cath <## "To confirm the registration, please send:" cath <## "To confirm the registration, please send:"
cath <# "SimpleX-Directory> /confirm 2:privacy" cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy" cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink <- groupAccepted cath "privacy" welcomeWithLink <- groupAccepted cath "privacy"
groupNotFound bob "privacy" groupNotFound bob "privacy"
completeRegistration superUser cath "privacy" "Privacy" welcomeWithLink 2 completeRegistration superUser cath "privacy" "Privacy" welcomeWithLink 2
@ -487,7 +490,7 @@ testDuplicateAskConfirmation tmp =
testDuplicateProhibitRegistration :: HasCallStack => FilePath -> IO () testDuplicateProhibitRegistration :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitRegistration tmp = testDuplicateProhibitRegistration tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy" registerGroup superUser bob "privacy" "Privacy"
@ -499,7 +502,7 @@ testDuplicateProhibitRegistration tmp =
testDuplicateProhibitConfirmation :: HasCallStack => FilePath -> IO () testDuplicateProhibitConfirmation :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitConfirmation tmp = testDuplicateProhibitConfirmation tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy" submitGroup bob "privacy" "Privacy"
@ -508,17 +511,17 @@ testDuplicateProhibitConfirmation tmp =
submitGroup cath "privacy" "Privacy" submitGroup cath "privacy" "Privacy"
cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory."
cath <## "To confirm the registration, please send:" cath <## "To confirm the registration, please send:"
cath <# "SimpleX-Directory> /confirm 2:privacy" cath <# "SimpleX-Directory> /confirm 1:privacy"
groupNotFound cath "privacy" groupNotFound cath "privacy"
completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1
groupFound cath "privacy" 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." cath <# "SimpleX-Directory> The group privacy (Privacy) is already listed in the directory, please choose another name."
testDuplicateProhibitWhenUpdated :: HasCallStack => FilePath -> IO () testDuplicateProhibitWhenUpdated :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitWhenUpdated tmp = testDuplicateProhibitWhenUpdated tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy" submitGroup bob "privacy" "Privacy"
@ -527,8 +530,8 @@ testDuplicateProhibitWhenUpdated tmp =
submitGroup cath "privacy" "Privacy" submitGroup cath "privacy" "Privacy"
cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory."
cath <## "To confirm the registration, please send:" cath <## "To confirm the registration, please send:"
cath <# "SimpleX-Directory> /confirm 2:privacy" cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy" cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink' <- groupAccepted cath "privacy" welcomeWithLink' <- groupAccepted cath "privacy"
groupNotFound cath "privacy" groupNotFound cath "privacy"
completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1
@ -549,7 +552,7 @@ testDuplicateProhibitWhenUpdated tmp =
testDuplicateProhibitApproval :: HasCallStack => FilePath -> IO () testDuplicateProhibitApproval :: HasCallStack => FilePath -> IO ()
testDuplicateProhibitApproval tmp = testDuplicateProhibitApproval tmp =
withDirectoryService tmp $ \superUser dsLink -> withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink bob `connectVia` dsLink
submitGroup bob "privacy" "Privacy" submitGroup bob "privacy" "Privacy"
@ -558,8 +561,8 @@ testDuplicateProhibitApproval tmp =
submitGroup cath "privacy" "Privacy" submitGroup cath "privacy" "Privacy"
cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory."
cath <## "To confirm the registration, please send:" cath <## "To confirm the registration, please send:"
cath <# "SimpleX-Directory> /confirm 2:privacy" cath <# "SimpleX-Directory> /confirm 1:privacy"
cath #> "@SimpleX-Directory /confirm 2:privacy" cath #> "@SimpleX-Directory /confirm 1:privacy"
welcomeWithLink' <- groupAccepted cath "privacy" welcomeWithLink' <- groupAccepted cath "privacy"
updateProfileWithLink cath "privacy" welcomeWithLink' 2 updateProfileWithLink cath "privacy" welcomeWithLink' 2
notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2 notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2
@ -572,6 +575,93 @@ testDuplicateProhibitApproval tmp =
superUser <# ("SimpleX-Directory> > " <> approve) superUser <# ("SimpleX-Directory> > " <> approve)
superUser <## " The group ID 2 (privacy) is already listed in the directory." 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 :: HasCallStack => TestCC -> TestCC -> IO ()
reapproveGroup superUser bob = do reapproveGroup superUser bob = do
superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy (" 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 bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
registerGroup :: TestCC -> TestCC -> String -> String -> IO () 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 submitGroup u n fn
welcomeWithLink <- groupAccepted u n 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 :: TestCC -> String -> String -> IO ()
submitGroup u n fn = do submitGroup u n fn = do
@ -642,17 +735,21 @@ groupAccepted u n = do
dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u -- welcome message with link dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u -- welcome message with link
completeRegistration :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () completeRegistration :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
completeRegistration su u n fn welcomeWithLink gId = do completeRegistration su u n fn welcomeWithLink gId =
updateProfileWithLink u n 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 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 :: TestCC -> String -> String -> Int -> IO ()
updateProfileWithLink u n welcomeWithLink gId = do updateProfileWithLink u n welcomeWithLink ugId = do
u ##> ("/set welcome " <> n <> " " <> welcomeWithLink) u ##> ("/set welcome " <> n <> " " <> welcomeWithLink)
u <## "description changed to:" u <## "description changed to:"
u <## welcomeWithLink 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." 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 () notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
@ -667,12 +764,16 @@ notifySuperUser su u n fn welcomeWithLink gId = do
su <# ("SimpleX-Directory> " <> approve) su <# ("SimpleX-Directory> " <> approve)
approveRegistration :: TestCC -> TestCC -> String -> Int -> IO () 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" let approve = "/approve " <> show gId <> ":" <> n <> " 1"
su #> ("@SimpleX-Directory " <> approve) su #> ("@SimpleX-Directory " <> approve)
su <# ("SimpleX-Directory> > " <> approve) su <# ("SimpleX-Directory> > " <> approve)
su <## " Group approved!" 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." u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
connectVia :: TestCC -> String -> IO () connectVia :: TestCC -> String -> IO ()
@ -713,13 +814,17 @@ removeMember gName admin removed = do
removed <## ("use /d " <> gn <> " to delete the group") removed <## ("use /d " <> gn <> " to delete the group")
groupFound :: TestCC -> String -> IO () 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 <# ("SimpleX-Directory> > " <> name) u <# ("SimpleX-Directory> > " <> name)
u <## " Found 1 group(s)" u <## " Found 1 group(s)"
u <#. ("SimpleX-Directory> " <> name <> " (") u <#. ("SimpleX-Directory> " <> name <> " (")
u <## "Welcome message:" 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 :: TestCC -> String -> IO ()
groupNotFound u s = do groupNotFound u s = do

4
tests/ChatTests/Direct.hs
View File

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

8
tests/ChatTests/Groups.hs
View File

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

2
tests/ChatTests/Profiles.hs
View File

@ -770,7 +770,7 @@ testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfil
dan <##> cath dan <##> cath
-- list groups -- list groups
cath ##> "/gs" cath ##> "/gs"
cath <## "i #secret_club" cath <## "i #secret_club (4 members)"
-- list group members -- list group members
alice ##> "/ms secret_club" alice ##> "/ms secret_club"
alice 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 createGroup3 gName cc1 cc2 cc3 = do
createGroup2 gName cc1 cc2 createGroup2 gName cc1 cc2
connectUsers cc1 cc3 connectUsers cc1 cc3
name1 <- userName cc1
name3 <- userName cc3 name3 <- userName cc3
sName2 <- showName cc2 sName2 <- showName cc2
sName3 <- showName cc3 sName3 <- showName cc3
@ -481,7 +482,7 @@ createGroup3 gName cc1 cc2 cc3 = do
cc3 <## ("#" <> gName <> ": you joined the group") cc3 <## ("#" <> gName <> ": you joined the group")
cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"), cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"),
do 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") cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected")
] ]