directory service: list pending groups (#5029)

* directory service: list pending groups * user commands to remove a group from directory and to set initial member role (TODO tests) * tests
2025-03-14 09:45:42 +00:00 · 2024-10-12 10:33:45 +01:00 · 2024-10-12 10:33:45 +01:00 · 7ab6e44a6e
commit 7ab6e44a6e
parent 26986686ca
4 changed files with 150 additions and 30 deletions
--- 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"
--- 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."
--- 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.")
--- 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 ->