From 8f723281369dcfdf0296d088fdca86617f28544f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 4 Aug 2023 09:23:16 +0100 Subject: [PATCH] directory: delist/relist groups when service or owner roles change (#2844) * directory: delist/relist groups when service or owner roles change * test role changes * correction Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * directory: suspend and resume group listing (#2848) * directory: suspend and resume group listing * correction Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- .../src/Directory/Events.hs | 18 +- .../src/Directory/Service.hs | 266 +++++++++++++----- .../src/Directory/Store.hs | 24 +- tests/Bots/DirectoryTests.hs | 139 ++++++++- 4 files changed, 361 insertions(+), 86 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 95216dffcf..4bde16e345 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -26,9 +26,9 @@ import Data.Either (fromRight) data DirectoryEvent = DEContactConnected Contact | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} - | DEServiceJoinedGroup ContactId GroupInfo + | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember} | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo} - | DEContactRoleChanged ContactId GroupInfo GroupMemberRole + | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed | DEServiceRoleChanged GroupInfo GroupMemberRole | DEContactRemovedFromGroup ContactId GroupInfo | DEContactLeftGroup ContactId GroupInfo @@ -38,15 +38,17 @@ data DirectoryEvent | DEItemEditIgnored Contact | DEItemDeleteIgnored Contact | DEContactCommand Contact ChatItemId ADirectoryCmd + deriving (Show) crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent crDirectoryEvent = \case CRContactConnected {contact} -> Just $ DEContactConnected contact CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} - CRUserJoinedGroup {groupInfo, hostMember} -> (`DEServiceJoinedGroup` groupInfo) <$> memberContactId hostMember + CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_) - CRMemberRole {groupInfo, member, toRole} -> (\ctId -> DEContactRoleChanged ctId groupInfo toRole) <$> memberContactId member - CRMemberRoleUser {groupInfo, toRole} -> Just $ DEServiceRoleChanged groupInfo toRole + CRMemberRole {groupInfo, member, toRole} + | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole + | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member CRDeletedMember {groupInfo, deletedMember} -> (`DEContactRemovedFromGroup` groupInfo) <$> memberContactId deletedMember CRLeftMember {groupInfo, member} -> (`DEContactLeftGroup` groupInfo) <$> memberContactId member CRDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo @@ -68,6 +70,8 @@ data SDirectoryRole (r :: DirectoryRole) where SDRUser :: SDirectoryRole 'DRUser SDRSuperUser :: SDirectoryRole 'DRSuperUser +deriving instance Show (SDirectoryRole r) + data DirectoryCmdTag (r :: DirectoryRole) where DCHelp_ :: DirectoryCmdTag 'DRUser DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser @@ -97,8 +101,12 @@ data DirectoryCmd (r :: DirectoryRole) where DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r +deriving instance Show (DirectoryCmd r) + data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r) +deriving instance Show (ADirectoryCmd) + directoryCmdP :: Parser ADirectoryCmd directoryCmdP = (A.char '/' *> cmdStrP) <|> (ADC SDRUser . DCSearchGroup <$> A.takeText) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 116440b91a..68d00268f2 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -34,7 +34,7 @@ import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Types import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError @@ -42,7 +42,14 @@ data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRe data DuplicateGroup = DGUnique -- display name or full name is unique | DGRegistered -- the group with the same names is registered, additional confirmation is required - | DGListed -- the group with the same names is listed, the registration is not allowed + | DGReserved -- the group with the same names is listed, the registration is not allowed + +data GroupRolesStatus + = GRSOk + | GRSServiceNotAdmin + | GRSContactNotOwner + | GRSBadRoles + deriving (Eq) welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do @@ -60,9 +67,9 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d forM_ (crDirectoryEvent resp) $ \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole - DEServiceJoinedGroup ctId g -> deServiceJoinedGroup ctId g + DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup - DEContactRoleChanged ctId g role -> deContactRoleChanged ctId g role + DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role DEServiceRoleChanged g role -> deServiceRoleChanged g role DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g DEContactLeftGroup ctId g -> deContactLeftGroup ctId g @@ -83,9 +90,13 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d atomically (getGroupReg st groupId) >>= \case Just gr -> action gr Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId - setGroupInactive GroupReg {groupRegStatus, dbGroupId} grStatus = atomically $ do + setGroupStatus GroupReg {groupRegStatus, dbGroupId} grStatus = atomically $ do writeTVar groupRegStatus grStatus - unlistGroup st dbGroupId + case grStatus of + GRSActive -> listGroup st dbGroupId + GRSSuspended -> reserveGroup st dbGroupId + GRSSuspendedBadRoles -> reserveGroup st dbGroupId + _ -> unlistGroup st dbGroupId groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} = n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d @@ -112,9 +123,9 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d if null gs then pure DGUnique else do - lgs <- readTVarIO $ listedGroups st - let listed = any (\GroupInfo {groupId = gId} -> gId `S.member` lgs) gs - pure $ if listed then DGListed else DGRegistered + (lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st) + let reserved = any (\GroupInfo {groupId = gId} -> gId `S.member` lgs || gId `S.member` rgs) gs + pure $ if reserved then DGReserved else DGRegistered processInvitation :: Contact -> GroupInfo -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do @@ -134,33 +145,58 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO () deGroupInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} fromMemberRole memberRole = do - case badInvitation fromMemberRole memberRole of + case badRolesMsg $ groupRolesStatus fromMemberRole memberRole of Just msg -> sendMessage cc ct msg Nothing -> getDuplicateGroup g >>= \case Just DGUnique -> processInvitation ct g Just DGRegistered -> askConfirmation - Just DGListed -> sendMessage cc ct $ groupAlreadyListed g - Nothing -> sendMessage cc ct $ "Unexpected error, please notify the developers." + Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g + Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers." where - badInvitation contactRole serviceRole = case (contactRole, serviceRole) of - (GROwner, GRAdmin) -> Nothing - (_, GRAdmin) -> Just "You must have a group *owner* role to register the group" - (GROwner, _) -> Just "You must grant directory service *admin* role to register the group" - _ -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group" askConfirmation = do 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 - deServiceJoinedGroup :: ContactId -> GroupInfo -> IO () - deServiceJoinedGroup ctId g = + badRolesMsg :: GroupRolesStatus -> Maybe String + badRolesMsg = \case + GRSOk -> Nothing + GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group" + GRSContactNotOwner -> Just "You must grant directory service *admin* role to register the group" + GRSBadRoles -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group" + + getGroupRolesStatus :: GroupInfo -> GroupReg -> IO (Maybe GroupRolesStatus) + getGroupRolesStatus GroupInfo {membership = GroupMember {memberRole = serviceRole}} gr = + rStatus <$$> getGroupMember gr + where + rStatus GroupMember {memberRole} = groupRolesStatus memberRole serviceRole + + groupRolesStatus :: GroupMemberRole -> GroupMemberRole -> GroupRolesStatus + groupRolesStatus contactRole serviceRole = case (contactRole, serviceRole) of + (GROwner, GRAdmin) -> GRSOk + (_, GRAdmin) -> GRSServiceNotAdmin + (GROwner, _) -> GRSContactNotOwner + _ -> GRSBadRoles + + getGroupMember :: GroupReg -> IO (Maybe GroupMember) + getGroupMember GroupReg {dbGroupId, dbOwnerMemberId} = + readTVarIO dbOwnerMemberId + $>>= \mId -> resp <$> sendChatCmd cc (APIGroupMemberInfo dbGroupId mId) + where + resp = \case + CRGroupMemberInfo {member} -> Just member + _ -> Nothing + + deServiceJoinedGroup :: ContactId -> GroupInfo -> GroupMember -> IO () + deServiceJoinedGroup ctId g owner = withGroupReg g "joined group" $ \gr -> when (ctId `isOwner` gr) $ do + atomically $ writeTVar (dbOwnerMemberId gr) (Just $ groupMemberId' owner) let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g notifyOwner gr $ T.unpack $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case CRGroupLinkCreated {connReqContact} -> do - setGroupInactive gr GRSPendingUpdate + setGroupStatus gr GRSPendingUpdate notifyOwner gr "Created the public link to join the group via this directory service that is always online.\n\n\ \Please add it to the group welcome message.\n\ @@ -196,11 +232,12 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d GRSPendingApproval n -> processProfileChange gr $ n + 1 GRSActive -> processProfileChange gr 1 GRSSuspended -> processProfileChange gr 1 + GRSSuspendedBadRoles -> processProfileChange gr 1 GRSRemoved -> pure () where isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_ GroupInfo {groupId, groupProfile = p} = fromGroup - GroupInfo {groupProfile = p'@GroupProfile {displayName = displayName', image = image'}} = toGroup + GroupInfo {groupProfile = p'} = toGroup groupRef = groupReference toGroup sameProfile GroupProfile {displayName = n, fullName = fn, image = i, description = d} @@ -208,31 +245,31 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d n == n' && fn == fn' && i == i' && d == d' groupLinkAdded gr = do getDuplicateGroup toGroup >>= \case - Nothing -> notifyOwner gr "Unexpected error, please notify the developers." - Just DGListed -> notifyOwner gr $ groupAlreadyListed toGroup + 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." let gaId = 1 - setGroupInactive gr $ GRSPendingApproval gaId - sendForApproval gr gaId + setGroupStatus gr $ GRSPendingApproval gaId + checkRolesSendToApprove gr gaId processProfileChange gr n' = groupProfileUpdate >>= \case GPNoServiceLink -> do - setGroupInactive gr GRSPendingUpdate + 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." GPServiceLinkRemoved -> do - setGroupInactive 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." notifySuperUsers $ "The group link is removed from " <> groupRef <> ", de-listed." GPServiceLinkAdded -> do - setGroupInactive gr $ GRSPendingApproval n' + setGroupStatus gr $ GRSPendingApproval n' notifyOwner gr $ "The group link is added to " <> groupRef <> "!\nIt is hidden from the directory until approved." notifySuperUsers $ "The group link is added to " <> groupRef <> "." - sendForApproval gr n' + checkRolesSendToApprove gr n' GPHasServiceLink -> do - setGroupInactive gr $ GRSPendingApproval n' + setGroupStatus gr $ GRSPendingApproval n' notifyOwner gr $ "The group " <> groupRef <> " is updated!\nIt is hidden from the directory until approved." notifySuperUsers $ "The group " <> groupRef <> " is updated." - sendForApproval gr n' + checkRolesSendToApprove gr n' GPServiceLinkError -> putStrLn $ "Error: no group link for " <> groupRef <> " pending approval." groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) where @@ -247,45 +284,97 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d | hasLinkNow -> GPServiceLinkAdded | otherwise -> GPNoServiceLink _ -> GPServiceLinkError - sendForApproval GroupReg {dbGroupId, dbContactId} gaId = do - ct_ <- getContact cc dbContactId - let text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ - <> groupInfoText p' <> "\n\nTo approve send:" - msg = maybe (MCText text) (\image -> MCImage {text, image}) image' - withSuperUsers $ \cId -> do - sendComposedMessage' cc cId Nothing msg - sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> T.unpack displayName' <> " " <> show gaId + checkRolesSendToApprove gr gaId = do + (badRolesMsg <$$> getGroupRolesStatus toGroup gr) >>= \case + Nothing -> notifyOwner gr "Error: getGroupRolesStatus. Please notify the developers." + Just (Just msg) -> notifyOwner gr msg + Just Nothing -> sendToApprove toGroup gr gaId - deContactRoleChanged :: ContactId -> GroupInfo -> GroupMemberRole -> IO () - deContactRoleChanged ctId g role = undefined + sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () + sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do + ct_ <- getContact cc dbContactId + let text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ + <> groupInfoText p <> "\n\nTo approve send:" + msg = maybe (MCText text) (\image -> MCImage {text, image}) image' + withSuperUsers $ \cId -> do + sendComposedMessage' cc cId Nothing msg + sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> T.unpack displayName <> " " <> show gaId + + deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () + deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = + withGroupReg g "contact role changed" $ \gr -> + when (ctId `isOwner` gr) $ do + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do + setGroupStatus gr GRSActive + notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again." + notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suCtRole + GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do + sendToApprove g gr gaId + notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." + GRSActive -> when (rStatus /= GRSOk) $ do + setGroupStatus gr GRSSuspendedBadRoles + notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole + _ -> pure () + where + 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 role = undefined + deServiceRoleChanged g serviceRole = do + withGroupReg g "service role changed" $ \gr -> do + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $ + whenContactIsOwner gr $ do + setGroupStatus gr GRSActive + notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again." + notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole + GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $ + whenContactIsOwner gr $ do + sendToApprove g gr gaId + notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." + GRSActive -> when (serviceRole /= GRAdmin) $ do + setGroupStatus gr GRSSuspendedBadRoles + notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole + _ -> pure () + 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 >>= + mapM_ (\cm@GroupMember {memberRole} -> when (memberRole == GROwner && memberActive cm) action) deContactRemovedFromGroup :: ContactId -> GroupInfo -> IO () deContactRemovedFromGroup ctId g = withGroupReg g "contact removed" $ \gr -> do when (ctId `isOwner` gr) $ do - setGroupInactive gr GRSRemoved + setGroupStatus gr GRSRemoved let groupRef = groupReference g - notifyOwner gr $ "You are removed from the group " <> groupRef <> ".\n\nGroup 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 " <> groupRef <> " 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 - setGroupInactive gr GRSRemoved + setGroupStatus gr GRSRemoved let groupRef = groupReference g - notifyOwner gr $ "You left the group " <> groupRef <> ".\n\nGroup 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 " <> groupRef <> " is de-listed (group owner left)." deServiceRemovedFromGroup :: GroupInfo -> IO () deServiceRemovedFromGroup g = withGroupReg g "service removed" $ \gr -> do - setGroupInactive gr GRSRemoved + setGroupStatus gr GRSRemoved let groupRef = groupReference g - notifyOwner gr $ serviceName <> " is removed from the group " <> groupRef <> ".\n\nGroup 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 " <> groupRef <> " is de-listed (directory service is removed)." deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () @@ -309,7 +398,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d let text = groupInfoText p msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ sendComposedMessage cc ct Nothing msg - Nothing -> sendReply "Unexpected error, please notify the developers." + Nothing -> sendReply "Error: getGroups. Please notify the developers." DCConfirmDuplicateGroup ugrId gName -> atomically (getGroupReg st ugrId) >>= \case Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" @@ -321,8 +410,8 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d readTVarIO groupRegStatus >>= \case GRSPendingConfirmation -> do getDuplicateGroup g >>= \case - Nothing -> sendMessage cc ct $ "Unexpected error, please notify the developers." - Just DGListed -> sendMessage cc ct $ groupAlreadyListed g + Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g _ -> 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 @@ -336,34 +425,56 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () deSuperUserCommand ct ciId cmd | superUser `elem` superUsers = case cmd of - DCApproveGroup {groupId, displayName = n, groupApprovalId} -> - atomically (getGroupReg st groupId) >>= \case - Nothing -> sendReply $ "Group ID " <> show groupId <> " not found" - Just GroupReg {dbContactId, groupRegStatus} -> do - readTVarIO groupRegStatus >>= \case + DCApproveGroup {groupId, displayName = n, groupApprovalId} -> do + getGroupAndReg groupId n >>= \case + Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." + Just (g, gr) -> + readTVarIO (groupRegStatus gr) >>= \case GRSPendingApproval gaId - | gaId == groupApprovalId -> do - getGroup cc groupId >>= \case - Just g@GroupInfo {groupProfile = GroupProfile {displayName = n'}} - | n == n' -> - getDuplicateGroup g >>= \case - Nothing -> sendReply $ "Unexpected error, please notify the developers." - Just DGListed -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." - _ -> do - atomically $ do - writeTVar groupRegStatus GRSActive - listGroup st groupId - sendReply "Group approved!" - sendMessage' cc dbContactId $ "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." - | otherwise -> sendReply "Incorrect group name" - Nothing -> pure () + | gaId == groupApprovalId -> do + getDuplicateGroup g >>= \case + Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." + _ -> do + getGroupRolesStatus g gr >>= \case + 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." + Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin + Just GRSContactNotOwner -> replyNotApproved "user is not an owner." + Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin + Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers." + where + replyNotApproved reason = sendReply $ "Group is not approved: " <> reason + serviceNotAdmin = serviceName <> " is not an admin." | otherwise -> sendReply "Incorrect approval code" _ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval." where groupRef = "ID " <> show groupId <> " (" <> T.unpack n <> ")" DCRejectGroup _gaId _gName -> pure () - DCSuspendGroup _gId _gName -> pure () - DCResumeGroup _gId _gName -> pure () + DCSuspendGroup groupId gName -> do + let groupRef = "ID " <> show groupId <> " (" <> T.unpack 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." + 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 <> ")" + 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!" + sendReply "Group listing resumed!" + _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." DCListGroups -> pure () DCCommandError tag -> sendReply $ "Command error: " <> show tag | otherwise = sendReply "You are not allowed to use this command" @@ -371,6 +482,15 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent + getGroupAndReg :: GroupId -> GroupName -> IO (Maybe (GroupInfo, GroupReg)) + getGroupAndReg gId gName = + getGroup cc gId + $>>= \g@GroupInfo {groupProfile = GroupProfile {displayName}} -> + if displayName == gName + then atomically (getGroupReg st gId) + $>>= \gr -> pure $ Just (g, gr) + else pure Nothing + getContact :: ChatController -> ContactId -> IO (Maybe Contact) getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) (CPLast 0) Nothing) where diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index b4508d6b92..d5d00b53b5 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -12,13 +12,15 @@ import qualified Data.Set as S data DirectoryStore = DirectoryStore { groupRegs :: TVar [GroupReg], - listedGroups :: TVar (Set GroupId) + listedGroups :: TVar (Set GroupId), + reservedGroups :: TVar (Set GroupId) } data GroupReg = GroupReg { userGroupRegId :: UserGroupRegId, dbGroupId :: GroupId, dbContactId :: ContactId, + dbOwnerMemberId :: TVar (Maybe GroupMemberId), groupRegStatus :: TVar GroupRegStatus } @@ -35,12 +37,14 @@ data GroupRegStatus | GRSPendingApproval GroupApprovalId | GRSActive | GRSSuspended + | GRSSuspendedBadRoles | GRSRemoved addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> STM () addGroupReg st ct GroupInfo {groupId} grStatus = do + dbOwnerMemberId <- newTVar Nothing groupRegStatus <- newTVar grStatus - let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, groupRegStatus} + let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, dbOwnerMemberId, groupRegStatus} modifyTVar' (groupRegs st) (gr :) getGroupReg :: DirectoryStore -> GroupRegId -> STM (Maybe GroupReg) @@ -58,10 +62,19 @@ filterListedGroups st gs = do pure $ filter (\GroupInfo {groupId} -> groupId `S.member` lgs) gs listGroup :: DirectoryStore -> GroupId -> STM () -listGroup st gId = modifyTVar' (listedGroups st) $ S.insert gId +listGroup st gId = do + modifyTVar' (listedGroups st) $ S.insert gId + modifyTVar' (reservedGroups st) $ S.delete gId + +reserveGroup :: DirectoryStore -> GroupId -> STM () +reserveGroup st gId = do + modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (reservedGroups st) $ S.insert gId unlistGroup :: DirectoryStore -> GroupId -> STM () -unlistGroup st gId = modifyTVar' (listedGroups st) $ S.delete gId +unlistGroup st gId = do + modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (reservedGroups st) $ S.delete gId data DirectoryLogRecord = CreateGroupReg GroupReg @@ -81,7 +94,8 @@ newDirectoryStore :: STM DirectoryStore newDirectoryStore = do groupRegs <- newTVar [] listedGroups <- newTVar mempty - pure DirectoryStore {groupRegs, listedGroups} + reservedGroups <- newTVar mempty + pure DirectoryStore {groupRegs, listedGroups, reservedGroups} readDirectoryState :: FilePath -> IO [GroupReg] readDirectoryState _ = pure [] diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index d1c34e7ada..1712efbd66 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -22,12 +22,17 @@ import Test.Hspec directoryServiceTests :: SpecWith FilePath directoryServiceTests = do it "should register group" testDirectoryService + it "should suspend and resume group" testSuspendResume describe "de-listing the group" $ do it "should de-list if owner leaves the group" testDelistedOwnerLeaves it "should de-list if owner is removed from the group" testDelistedOwnerRemoved it "should NOT de-list if another member leaves the group" testNotDelistedMemberLeaves it "should NOT de-list if another member is removed from the group" testNotDelistedMemberRemoved it "should de-list if service is removed from the group" testDelistedServiceRemoved + it "should de-list/re-list when service/owner roles change" testDelistedRoleChanges + it "should NOT de-list if another member role changes" testNotDelistedMemberRoleChanged + it "should NOT send to approval if roles are incorrect" testNotSentApprovalBadRoles + it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles describe "should require re-approval if profile is changed by" $ do it "the registration owner" testRegOwnerChangedProfile it "another owner" testAnotherOwnerChangedProfile @@ -146,6 +151,24 @@ testDirectoryService tmp = su <## "To approve send:" su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId) +testSuspendResume :: HasCallStack => FilePath -> IO () +testSuspendResume tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + groupFound bob "privacy" + superUser #> "@SimpleX-Directory /suspend 1:privacy" + superUser <# "SimpleX-Directory> > /suspend 1:privacy" + superUser <## " Group suspended!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is suspended and hidden from directory. Please contact the administrators." + groupNotFound bob "privacy" + superUser #> "@SimpleX-Directory /resume 1:privacy" + superUser <# "SimpleX-Directory> > /resume 1:privacy" + superUser <## " Group listing resumed!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!" + groupFound bob "privacy" + testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO () testDelistedOwnerLeaves tmp = withDirectoryService tmp $ \superUser dsLink -> @@ -158,7 +181,7 @@ testDelistedOwnerLeaves tmp = cath <## "#privacy: bob left the group" bob <# "SimpleX-Directory> You left the group ID 1 (privacy)." bob <## "" - bob <## "Group is no longer listed in the directory." + bob <## "The group is no longer listed in the directory." superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner left)." groupNotFound cath "privacy" @@ -173,7 +196,7 @@ testDelistedOwnerRemoved tmp = removeMember "privacy" cath bob bob <# "SimpleX-Directory> You are removed from the group ID 1 (privacy)." bob <## "" - bob <## "Group is no longer listed in the directory." + bob <## "The group is no longer listed in the directory." superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner is removed)." groupNotFound cath "privacy" @@ -215,10 +238,120 @@ testDelistedServiceRemoved tmp = cath <## "#privacy: bob removed SimpleX-Directory from the group" bob <# "SimpleX-Directory> SimpleX-Directory is removed from the group ID 1 (privacy)." bob <## "" - bob <## "Group is no longer listed in the directory." + bob <## "The group is no longer listed in the directory." superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)." groupNotFound cath "privacy" +testDelistedRoleChanges :: HasCallStack => FilePath -> IO () +testDelistedRoleChanges tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + groupFound 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" + cath <## "#privacy: bob changed the role of SimpleX-Directory from admin to member" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to member." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (SimpleX-Directory role is changed to member)." + groupNotFound cath "privacy" + -- re-listed if service role changed back without profile changes + cath ##> "/mr privacy SimpleX-Directory admin" + cath <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <## "#privacy: cath changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + 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" + -- de-listed if owner role changed + cath ##> "/mr privacy bob admin" + cath <## "#privacy: you changed the role of bob from owner to admin" + bob <## "#privacy: cath changed your role from owner to admin" + bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (user role is set to admin)." + groupNotFound cath "privacy" + -- re-listed if owner role changed back without profile changes + cath ##> "/mr privacy bob owner" + cath <## "#privacy: you changed the role of bob from admin to owner" + bob <## "#privacy: cath changed your role from admin to owner" + bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to owner." + 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" + +testNotDelistedMemberRoleChanged :: HasCallStack => FilePath -> IO () +testNotDelistedMemberRoleChanged tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + groupFound 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" + +testNotSentApprovalBadRoles :: HasCallStack => FilePath -> IO () +testNotSentApprovalBadRoles tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + cath `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + bob ##> "/mr privacy SimpleX-Directory member" + bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + updateProfileWithLink bob "privacy" welcomeWithLink 1 + bob <# "SimpleX-Directory> You must grant directory service admin role to register the group" + bob ##> "/mr privacy SimpleX-Directory admin" + bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is submitted for approval." + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupNotFound cath "privacy" + approveRegistration superUser bob "privacy" 1 + groupFound cath "privacy" + +testNotApprovedBadRoles :: HasCallStack => FilePath -> IO () +testNotApprovedBadRoles tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + cath `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + updateProfileWithLink bob "privacy" welcomeWithLink 1 + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + bob ##> "/mr privacy SimpleX-Directory member" + bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + let approve = "/approve 1:privacy 1" + superUser #> ("@SimpleX-Directory " <> approve) + superUser <# ("SimpleX-Directory> > " <> approve) + superUser <## " Group is not approved: user is not an owner." + groupNotFound cath "privacy" + bob ##> "/mr privacy SimpleX-Directory admin" + bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is submitted for approval." + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + approveRegistration superUser bob "privacy" 1 + groupFound cath "privacy" + testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO () testRegOwnerChangedProfile tmp = withDirectoryService tmp $ \superUser dsLink ->