diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 64e6acf1d8..3119815d7b 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -106,11 +106,13 @@ data DirectoryCmdTag (r :: DirectoryRole) where DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser DCListUserGroups_ :: DirectoryCmdTag 'DRUser DCDeleteGroup_ :: DirectoryCmdTag 'DRUser + DCSetRole_ :: DirectoryCmdTag 'DRUser DCApproveGroup_ :: DirectoryCmdTag 'DRSuperUser DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser + DCListPendingGroups_ :: DirectoryCmdTag 'DRSuperUser DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser deriving instance Show (DirectoryCmdTag r) @@ -127,11 +129,13 @@ data DirectoryCmd (r :: DirectoryRole) where DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser DCListUserGroups :: DirectoryCmd 'DRUser DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser + DCSetRole :: GroupId -> GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser + DCListPendingGroups :: Int -> DirectoryCmd 'DRSuperUser DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r @@ -163,11 +167,13 @@ directoryCmdP = "list" -> u DCListUserGroups_ "ls" -> u DCListUserGroups_ "delete" -> u DCDeleteGroup_ + "role" -> u DCSetRole_ "approve" -> su DCApproveGroup_ "reject" -> su DCRejectGroup_ "suspend" -> su DCSuspendGroup_ "resume" -> su DCResumeGroup_ "last" -> su DCListLastGroups_ + "pending" -> su DCListPendingGroups_ "exec" -> su DCExecuteCommand_ "x" -> su DCExecuteCommand_ _ -> fail "bad command tag" @@ -184,14 +190,19 @@ directoryCmdP = DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup DCListUserGroups_ -> pure DCListUserGroups DCDeleteGroup_ -> gc DCDeleteGroup + DCSetRole_ -> do + (groupId, displayName) <- gc (,) + memberRole <- A.space *> ("member" $> GRMember <|> "observer" $> GRObserver) + pure $ DCSetRole groupId displayName memberRole DCApproveGroup_ -> do (groupId, displayName) <- gc (,) groupApprovalId <- A.space *> A.decimal - pure $ DCApproveGroup {groupId, displayName, groupApprovalId} + pure DCApproveGroup {groupId, displayName, groupApprovalId} DCRejectGroup_ -> gc DCRejectGroup DCSuspendGroup_ -> gc DCSuspendGroup DCResumeGroup_ -> gc DCResumeGroup DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10) + DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10) DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText) where gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP @@ -214,13 +225,15 @@ directoryCmdTag = \case DCRecentGroups -> "new" DCSubmitGroup _ -> "submit" DCConfirmDuplicateGroup {} -> "confirm" - DCListUserGroups -> "list" + DCListUserGroups -> "list" DCDeleteGroup {} -> "delete" DCApproveGroup {} -> "approve" + DCSetRole {} -> "role" DCRejectGroup {} -> "reject" DCSuspendGroup {} -> "suspend" DCResumeGroup {} -> "resume" DCListLastGroups _ -> "last" + DCListPendingGroups _ -> "pending" DCExecuteCommand _ -> "exec" DCUnknownCommand -> "unknown" DCCommandError _ -> "error" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 2b12427638..ba03642a28 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -23,6 +23,7 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Directory.Events @@ -447,30 +448,43 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent DCSubmitGroup _link -> pure () DCConfirmDuplicateGroup ugrId gName -> - atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case - Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" - Just GroupReg {dbGroupId, groupRegStatus} -> do - getGroup cc dbGroupId >>= \case - Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" - Just g@GroupInfo {groupProfile = GroupProfile {displayName}} - | displayName == gName -> - readTVarIO groupRegStatus >>= \case - GRSPendingConfirmation -> do - getDuplicateGroup g >>= \case - 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 + withUserGroupReg ugrId gName $ \gr g@GroupInfo {groupProfile = GroupProfile {displayName}} -> + readTVarIO (groupRegStatus gr) >>= \case + GRSPendingConfirmation -> + getDuplicateGroup g >>= \case + 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." 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 -> + withUserGroupReg ugrId gName $ \gr GroupInfo {groupProfile = GroupProfile {displayName}} -> do + delGroupReg st gr + sendReply $ T.unpack $ "Your group " <> displayName <> " is deleted from the directory" + DCSetRole ugrId gName mRole -> + withUserGroupReg ugrId gName $ \_gr GroupInfo {groupId, groupProfile = GroupProfile {displayName}} -> do + gLink_ <- setGroupLinkRole cc groupId mRole + sendReply $ T.unpack $ case gLink_ of + Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated" + Just gLink -> + ("The initial member role for the group " <> displayName <> " is set to *" <> decodeLatin1 (strEncode mRole) <> "*\n\n") + <> ("*Please note*: it applies only to members joining via this link: " <> safeDecodeUtf8 (strEncode $ simplexChatContact gLink)) DCUnknownCommand -> sendReply "Unknown command" DCCommandError tag -> sendReply $ "Command error: " <> show tag where + withUserGroupReg ugrId gName action = + atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case + Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Just gr@GroupReg {dbGroupId} -> do + getGroup cc dbGroupId >>= \case + Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Just g@GroupInfo {groupProfile = GroupProfile {displayName}} + | displayName == gName -> action gr g + | otherwise -> sendReply $ "Group ID " <> show ugrId <> " has the display name " <> T.unpack displayName sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent withFoundListedGroups s_ action = getGroups_ s_ >>= \case @@ -576,13 +590,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!" sendReply "Group listing resumed!" _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." - 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 + DCListLastGroups count -> listGroups count False + DCListPendingGroups count -> listGroups count True DCExecuteCommand cmdStr -> sendChatCmdStr cc cmdStr >>= \r -> do ts <- getCurrentTime @@ -593,6 +602,17 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi where superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent + listGroups count pending = + readTVarIO (groupRegs st) >>= \groups -> do + grs <- + if pending + then filterM (fmap pendingApproval . readTVarIO . groupRegStatus) groups + else pure groups + 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 getGroupAndReg :: GroupId -> GroupName -> IO (Maybe (GroupInfo, GroupReg)) getGroupAndReg gId gName = @@ -641,5 +661,12 @@ getGroupAndSummary cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) CRGroupInfo {groupInfo, groupSummary} -> Just (groupInfo, groupSummary) _ -> Nothing +setGroupLinkRole :: ChatController -> GroupId -> GroupMemberRole -> IO (Maybe ConnReqContact) +setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole gId mRole) + where + resp = \case + CRGroupLink _ _ gLink _ -> Just gLink + _ -> Nothing + unexpectedError :: String -> String unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers." diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index c810102e08..cecb253e8d 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -12,6 +12,7 @@ module Directory.Store GroupApprovalId, restoreDirectoryStore, addGroupReg, + delGroupReg, setGroupStatus, setGroupRegOwner, getGroupReg, @@ -19,6 +20,7 @@ module Directory.Store getUserGroupRegs, filterListedGroups, groupRegStatusText, + pendingApproval, ) where @@ -79,6 +81,11 @@ data GroupRegStatus | GRSSuspendedBadRoles | GRSRemoved +pendingApproval :: GroupRegStatus -> Bool +pendingApproval = \case + GRSPendingApproval _ -> True + _ -> False + data DirectoryStatus = DSListed | DSReserved | DSRegistered groupRegStatusText :: GroupRegStatus -> Text @@ -118,6 +125,12 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do | dbContactId == ctId && userGroupRegId > mx = userGroupRegId | otherwise = mx +delGroupReg :: DirectoryStore -> GroupReg -> IO () +delGroupReg st GroupReg {dbGroupId = gId} = do + logGDelete st gId + atomically $ unlistGroup st gId + atomically $ modifyTVar' (groupRegs st) $ filter ((gId ==) . dbGroupId) + setGroupStatus :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO () setGroupStatus st gr grStatus = do logGUpdateStatus st (dbGroupId gr) grStatus @@ -167,10 +180,15 @@ unlistGroup st gId = do data DirectoryLogRecord = GRCreate GroupRegData + | GRDelete GroupId | GRUpdateStatus GroupId GroupRegStatus | GRUpdateOwner GroupId GroupMemberId -data DLRTag = GRCreate_ | GRUpdateStatus_ | GRUpdateOwner_ +data DLRTag + = GRCreate_ + | GRDelete_ + | GRUpdateStatus_ + | GRUpdateOwner_ logDLR :: DirectoryStore -> DirectoryLogRecord -> IO () logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r) @@ -178,6 +196,9 @@ logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r) logGCreate :: DirectoryStore -> GroupRegData -> IO () logGCreate st = logDLR st . GRCreate +logGDelete :: DirectoryStore -> GroupId -> IO () +logGDelete st = logDLR st . GRDelete + logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO () logGUpdateStatus st = logDLR st .: GRUpdateStatus @@ -187,11 +208,13 @@ logGUpdateOwner st = logDLR st .: GRUpdateOwner instance StrEncoding DLRTag where strEncode = \case GRCreate_ -> "GCREATE" + GRDelete_ -> "GDELETE" GRUpdateStatus_ -> "GSTATUS" GRUpdateOwner_ -> "GOWNER" strP = A.takeTill (== ' ') >>= \case "GCREATE" -> pure GRCreate_ + "GDELETE" -> pure GRDelete_ "GSTATUS" -> pure GRUpdateStatus_ "GOWNER" -> pure GRUpdateOwner_ _ -> fail "invalid DLRTag" @@ -199,13 +222,15 @@ instance StrEncoding DLRTag where instance StrEncoding DirectoryLogRecord where strEncode = \case GRCreate gr -> strEncode (GRCreate_, gr) + GRDelete gId -> strEncode (GRDelete_, gId) GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus) GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId) strP = - strP >>= \case - GRCreate_ -> GRCreate <$> (A.space *> strP) - GRUpdateStatus_ -> GRUpdateStatus <$> (A.space *> A.decimal) <*> (A.space *> strP) - GRUpdateOwner_ -> GRUpdateOwner <$> (A.space *> A.decimal) <*> (A.space *> A.decimal) + strP_ >>= \case + GRCreate_ -> GRCreate <$> strP + GRDelete_ -> GRDelete <$> strP + GRUpdateStatus_ -> GRUpdateStatus <$> A.decimal <*> _strP + GRUpdateOwner_ -> GRUpdateOwner <$> A.decimal <* A.space <*> A.decimal instance StrEncoding GroupRegData where strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = @@ -314,6 +339,9 @@ readDirectoryData f = putStrLn $ "Warning: duplicate group with ID " <> show gId <> ", group replaced." pure $ M.insert gId gr m + GRDelete gId -> case M.lookup gId m of + Just _ -> pure $ M.delete gId m + Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", deletion ignored.") GRUpdateStatus gId groupRegStatus_ -> case M.lookup gId m of Just gr -> pure $ M.insert gId gr {groupRegStatus_} m Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.") diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 7cd775c5ee..3a3e9f889f 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -28,6 +28,8 @@ directoryServiceTests :: SpecWith FilePath directoryServiceTests = do it "should register group" testDirectoryService it "should suspend and resume group" testSuspendResume + it "should delete group registration" testDeleteGroup + it "should change initial member role" testSetRole it "should join found group via link" testJoinGroup it "should support group names with spaces" testGroupNameWithSpaces it "should return more groups in search, all and recent groups" testSearchGroups @@ -139,6 +141,15 @@ testDirectoryService tmp = bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message." bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours." approvalRequested superUser welcomeWithLink' (1 :: Int) + superUser #> "@SimpleX-Directory /pending" + superUser <# "SimpleX-Directory> > /pending" + superUser <## " 1 registered group(s)" + superUser <# "SimpleX-Directory> 1. PSA (Privacy, Security & Anonymity)" + superUser <## "Welcome message:" + superUser <##. "Welcome! Link to join the group PSA: " + superUser <## "Owner: bob" + superUser <## "2 members" + superUser <## "Status: pending admin approval" superUser #> "@SimpleX-Directory /approve 1:PSA 1" superUser <# "SimpleX-Directory> > /approve 1:PSA 1" superUser <## " Group approved!" @@ -197,6 +208,47 @@ testSuspendResume tmp = bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!" groupFound bob "privacy" +testDeleteGroup :: HasCallStack => FilePath -> IO () +testDeleteGroup tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + groupFound bob "privacy" + bob #> "@SimpleX-Directory /delete 1:privacy" + bob <# "SimpleX-Directory> > /delete 1:privacy" + bob <## " Your group privacy is deleted from the directory" + groupNotFound bob "privacy" + +testSetRole :: HasCallStack => FilePath -> IO () +testSetRole tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + groupFound bob "privacy" + bob #> "@SimpleX-Directory /role 1:privacy observer" + bob <# "SimpleX-Directory> > /role 1:privacy observer" + bob <## " The initial member role for the group privacy is set to observer" + bob <## "" + note <- getTermLine bob + let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note + cath ##> ("/c " <> groupLink) + cath <## "connection request sent!" + cath <## "#privacy: joining the group..." + cath <## "#privacy: you joined the group" + cath <#. "#privacy SimpleX-Directory> Link to join the group privacy: https://simplex.chat/" + cath <## "#privacy: member bob (Bob) is connected" + bob <## "#privacy: SimpleX-Directory added cath (Catherine) to the group (connecting...)" + bob <## "#privacy: new member cath is connected" + bob ##> "/ms #privacy" + bob <## "bob (Bob): owner, you, created group" + bob <## "SimpleX-Directory: admin, invited, connected" + bob <## "cath (Catherine): observer, connected" + cath ##> "#privacy hello" + cath <## "#privacy: you don't have permission to send messages" + testJoinGroup :: HasCallStack => FilePath -> IO () testJoinGroup tmp = withDirectoryServiceCfg tmp testCfgGroupLinkViaContact $ \superUser dsLink ->