directory: process group deletion correctly, group of owners (#5540)

* directory: process group deletion correctly, command to invite owners of listed groups to the group of owners

* dont invite to owners group twice

apps/simplex-directory-service/src/Directory/Events.hs

@@ -116,6 +116,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where
   DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin
   DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin
   DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin
+  DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin
   DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
 
 deriving instance Show (DirectoryCmdTag r)
@@ -141,6 +142,7 @@ data DirectoryCmd (r :: DirectoryRole) where
   DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin
   DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
   DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin
+  DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
   DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
   DCUnknownCommand :: DirectoryCmd 'DRUser
   DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -181,6 +183,7 @@ directoryCmdP =
         "pending" -> au DCListPendingGroups_
         "link" -> au DCShowGroupLink_
         "owner" -> au DCSendToGroupOwner_
+        "invite" -> au DCInviteOwnerToGroup_
         "exec" -> su DCExecuteCommand_
         "x" -> su DCExecuteCommand_
         _ -> fail "bad command tag"
@@ -216,6 +219,7 @@ directoryCmdP =
         (groupId, displayName) <- gc (,)
         msg <- A.space *> A.takeText
         pure $ DCSendToGroupOwner groupId displayName msg
+      DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup
       DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
       where
         gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP
@@ -249,6 +253,7 @@ directoryCmdTag = \case
   DCListPendingGroups _ -> "pending"
   DCShowGroupLink {} -> "link"
   DCSendToGroupOwner {} -> "owner"
+  DCInviteOwnerToGroup {} -> "invite"
   DCExecuteCommand _ -> "exec"
   DCUnknownCommand -> "unknown"
   DCCommandError _ -> "error"

apps/simplex-directory-service/src/Directory/Options.hs

@@ -21,6 +21,7 @@ data DirectoryOpts = DirectoryOpts
   { coreOptions :: CoreChatOpts,
     adminUsers :: [KnownContact],
     superUsers :: [KnownContact],
+    ownersGroup :: Maybe KnownGroup,
     directoryLog :: Maybe FilePath,
     serviceName :: T.Text,
     runCLI :: Bool,
@@ -36,6 +37,7 @@ directoryOpts appDir defaultDbName = do
       parseKnownContacts
       ( long "admin-users"
           <> metavar "ADMIN_USERS"
+          <> value []
           <> help "Comma-separated list of admin-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
       )
   superUsers <-
@@ -45,6 +47,14 @@ directoryOpts appDir defaultDbName = do
           <> metavar "SUPER_USERS"
           <> help "Comma-separated list of super-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
       )
+  ownersGroup <-
+    optional $
+      option
+        parseKnownGroup
+        ( long "owners-group"
+            <> metavar "OWNERS_GROUP"
+            <> help "The group of group owners in the format GROUP_ID:DISPLAY_NAME - owners of listed groups will be invited automatically"
+        )
   directoryLog <-
     Just
       <$> strOption
@@ -69,6 +79,7 @@ directoryOpts appDir defaultDbName = do
       { coreOptions,
         adminUsers,
         superUsers,
+        ownersGroup,
         directoryLog,
         serviceName = T.pack serviceName,
         runCLI,

apps/simplex-directory-service/src/Directory/Service.hs

@@ -18,7 +18,8 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Logger.Simple
 import Control.Monad
-import Data.Maybe (fromMaybe, maybeToList)
+import Data.List (find)
+import Data.Maybe (fromMaybe, isJust, maybeToList)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -103,7 +104,7 @@ directoryService st opts@DirectoryOpts {testing} user cc = do
     directoryServiceEvent st opts env user cc resp
 
 directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO ()
-directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults} ServiceState {searchRequests} user@User {userId} cc event =
+directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests} user@User {userId} cc event =
   forM_ (crDirectoryEvent event) $ \case
     DEContactConnected ct -> deContactConnected ct
     DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
@@ -114,7 +115,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, sea
     DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g
     DEContactLeftGroup ctId g -> deContactLeftGroup ctId g
     DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g
-    DEGroupDeleted _g -> pure ()
+    DEGroupDeleted g -> deGroupDeleted g
     DEUnsupportedMessage _ct _ciId -> pure ()
     DEItemEditIgnored _ct -> pure ()
     DEItemDeleteIgnored _ct -> pure ()
@@ -438,6 +439,14 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, sea
         notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
         notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)."
 
+    deGroupDeleted :: GroupInfo -> IO ()
+    deGroupDeleted g = do
+      logInfo $ "group removed " <> viewGroupName g
+      withGroupReg g "group removed" $ \gr -> do
+        setGroupStatus st gr GRSRemoved
+        notifyOwner gr $ "The group " <> userGroupReference gr g <> " is deleted.\n\nThe group is no longer listed in the directory."
+        notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group is deleted)."
+
     deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO ()
     deUserCommand ct ciId = \case
       DCHelp ->
@@ -582,8 +591,15 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, sea
                               setGroupStatus st gr GRSActive
                               let approved = "The group " <> userGroupReference' gr n <> " is approved"
                               notifyOwner gr $ approved <> " and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
-                              sendReply "Group approved!"
-                              notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct)
+                              invited <-
+                                forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do
+                                  inviteToOwnersGroup og gr $ \case
+                                    Right () -> do
+                                      owner <- groupOwnerInfo groupRef $ dbContactId gr
+                                      pure $ "Invited " <> owner <> " to owners' group " <> viewName ogName
+                                    Left err -> pure err
+                              sendReply $ "Group approved!" <> maybe "" ("\n" <>) invited
+                              notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct) <> fromMaybe "" invited
                             Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
                             Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
                             Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
@@ -641,10 +657,20 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, sea
             let groupRef = groupReference' groupId gName
             withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId} -> do
               notifyOwner gr msg
-              owner_ <- getContact cc dbContactId
-              let ownerInfo = "the owner of the group " <> groupRef
-                  ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", "
-              sendReply $ "Forwarded to " <> maybe "" ownerName owner_ <> ownerInfo
+              owner <- groupOwnerInfo groupRef dbContactId
+              sendReply $ "Forwarded to " <> owner
+          DCInviteOwnerToGroup groupId gName -> case ownersGroup of
+            Just og@KnownGroup {localDisplayName = ogName} ->
+              withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId = ctId} -> do
+                inviteToOwnersGroup og gr $ \case
+                  Right () -> do
+                    let groupRef = groupReference' groupId gName
+                    owner <- groupOwnerInfo groupRef ctId
+                    let invited =  " invited " <> owner <> " to owners' group " <> viewName ogName
+                    notifyOtherSuperUsers $ viewName (localDisplayName' ct) <> invited
+                    sendReply $ "you" <> invited
+                  Left err -> sendReply err
+            Nothing -> sendReply "owners' group is not specified"
           DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
       | otherwise = sendReply "You are not allowed to use this command"
       where
@@ -662,6 +688,29 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, sea
               ct_ <- getContact cc dbContactId
               let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_
               sendGroupInfo ct gr dbGroupId $ Just ownerStr
+        inviteToOwnersGroup :: KnownGroup -> GroupReg -> (Either Text () -> IO a) -> IO a
+        inviteToOwnersGroup KnownGroup {groupId = ogId} GroupReg {dbContactId = ctId} cont =
+          sendChatCmd cc (APIListMembers ogId) >>= \case
+            CRGroupMembers _ (Group _ ms)
+              | alreadyMember ms -> cont $ Left "Owner is already a member of owners' group"
+              | otherwise -> do
+                  sendChatCmd cc (APIAddMember ogId ctId GRMember) >>= \case
+                    CRSentGroupInvitation {} -> do
+                      printLog cc CLLInfo $ "invited contact ID " <> show ctId <> " to owners' group"
+                      cont $ Right ()
+                    r -> contErr r
+            r -> contErr r
+          where
+            alreadyMember = isJust . find ((Just ctId == ) . memberContactId)
+            contErr r = do
+              let err = "error inviting contact ID " <> tshow ctId <> " to owners' group: " <> tshow r
+              putStrLn $ T.unpack err
+              cont $ Left err
+        groupOwnerInfo groupRef dbContactId = do
+          owner_ <- getContact cc dbContactId
+          let ownerInfo = "the owner of the group " <> groupRef
+              ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", "
+          pure $ maybe "" ownerName owner_ <> ownerInfo
 
     deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
     deSuperUserCommand ct ciId cmd

src/Simplex/Chat/Bot/KnownContacts.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Chat.Bot.KnownContacts where
 
@@ -18,8 +20,13 @@ data KnownContact = KnownContact
   }
   deriving (Eq)
 
+data KnownGroup = KnownGroup
+  { groupId :: Int64,
+    localDisplayName :: Text
+  }
+
 knownContactNames :: [KnownContact] -> Text
-knownContactNames = T.intercalate ", " . map (("@" <>) . localDisplayName)
+knownContactNames = T.intercalate ", " . map (("@" <>) . (\KnownContact {localDisplayName = n} -> n))
 
 parseKnownContacts :: ReadM [KnownContact]
 parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack
@@ -31,3 +38,12 @@ knownContactsP = contactP `A.sepBy1` A.char ','
       contactId <- A.decimal <* A.char ':'
       localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
       pure KnownContact {contactId, localDisplayName}
+
+parseKnownGroup :: ReadM KnownGroup
+parseKnownGroup = eitherReader $ parseAll knownGroupP . encodeUtf8 . T.pack
+
+knownGroupP :: A.Parser KnownGroup
+knownGroupP = do
+  groupId <- A.decimal <* A.char ':'
+  localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
+  pure KnownGroup {groupId, localDisplayName}

src/Simplex/Chat/Controller.hs

@@ -353,7 +353,7 @@ data ChatCommand
   | APIGetNtfConns {nonce :: C.CbNonce, encNtfInfo :: ByteString}
   | ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId}
   | APIAddMember GroupId ContactId GroupMemberRole
-  | APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter} 
+  | APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter}
   | APIMemberRole GroupId GroupMemberId GroupMemberRole
   | APIBlockMemberForAll GroupId GroupMemberId Bool
   | APIRemoveMember GroupId GroupMemberId

src/Simplex/Chat/Mobile.hs

@@ -204,7 +204,7 @@ mobileChatOpts dbFilePrefix =
             logServerHosts = True,
             logAgent = Nothing,
             logFile = Nothing,
-            tbqSize = 1024,
+            tbqSize = 4096,
             highlyAvailable = False,
             yesToUpMigrations = False
           },

tests/Bots/DirectoryTests.hs

@@ -10,7 +10,7 @@ import ChatClient
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Exception (finally)
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
 import qualified Data.Text as T
 import qualified Directory.Events as DE
 import Directory.Options
@@ -36,12 +36,14 @@ directoryServiceTests = do
   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
+  it "should invite to owners' group if specified" testInviteToOwnersGroup
   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 if group is deleted" testDelistedGroupDeleted
     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
@@ -66,8 +68,8 @@ directoryServiceTests = do
 directoryProfile :: Profile
 directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
 
-mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
-mkDirectoryOpts tmp superUsers =
+mkDirectoryOpts :: FilePath -> [KnownContact] -> Maybe KnownGroup -> DirectoryOpts
+mkDirectoryOpts tmp superUsers ownersGroup =
   DirectoryOpts
     { coreOptions =
         testCoreOpts
@@ -82,6 +84,7 @@ mkDirectoryOpts tmp superUsers =
           },
       adminUsers = [],
       superUsers,
+      ownersGroup,
       directoryLog = Just $ tmp </> "directory_service.log",
       serviceName = "SimpleX-Directory",
       runCLI = False,
@@ -432,6 +435,24 @@ testSearchGroups tmp =
       u <##. "Link to join the group "
       u <## (show count <> " members")
 
+testInviteToOwnersGroup :: HasCallStack => FilePath -> IO ()
+testInviteToOwnersGroup tmp =
+  withDirectoryServiceCfgOwnersGroup tmp testCfg True $ \superUser dsLink ->
+    withNewTestChatCfg tmp testCfg "bob" bobProfile $ \bob -> do
+      bob `connectVia` dsLink
+      registerGroupId superUser bob "privacy" "Privacy" 2 1
+      bob <## "#owners: SimpleX-Directory invites you to join the group as member"
+      bob <## "use /j owners to accept"
+      superUser <## "Invited @bob, the owner of the group ID 2 (privacy) to owners' group owners"
+      bob ##> "/j owners"
+      bob <## "#owners: you joined the group"
+      bob <## "#owners: member alice (Alice) is connected"
+      superUser <## "#owners: SimpleX-Directory added bob (Bob) to the group (connecting...)"
+      superUser <## "#owners: new member bob is connected"
+      -- second group
+      registerGroupId superUser bob "security" "Security" 3 2
+      superUser <## "Owner is already a member of owners' group"
+
 testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
 testDelistedOwnerLeaves tmp =
   withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
@@ -505,6 +526,30 @@ testDelistedServiceRemoved tmp =
         superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)."
         groupNotFound cath "privacy"
 
+testDelistedGroupDeleted :: HasCallStack => FilePath -> IO ()
+testDelistedGroupDeleted 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 GROwner
+        joinGroup "privacy" cath bob
+        cath <## "#privacy: member SimpleX-Directory_1 is connected"
+        cath <## "contact and member are merged: SimpleX-Directory, #privacy SimpleX-Directory_1"
+        cath <## "use @SimpleX-Directory <message> to send messages"
+        bob ##> "/d #privacy"
+        bob <## "#privacy: you deleted the group"
+        bob <# "SimpleX-Directory> The group ID 1 (privacy) is deleted."
+        bob <## ""
+        bob <## "The group is no longer listed in the directory."
+        cath <## "#privacy: bob deleted the group"
+        cath <## "use /d #privacy to delete the local copy of the group"
+        superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group is deleted)."
+        groupNotFound cath "privacy"
+
 testDelistedRoleChanges :: HasCallStack => FilePath -> IO ()
 testDelistedRoleChanges tmp =
   withDirectoryServiceCfg tmp testCfgCreateGroupDirect $ \superUser dsLink ->
@@ -980,14 +1025,28 @@ withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ())
 withDirectoryService tmp = withDirectoryServiceCfg tmp testCfg
 
 withDirectoryServiceCfg :: HasCallStack => FilePath -> ChatConfig -> (TestCC -> String -> IO ()) -> IO ()
-withDirectoryServiceCfg tmp cfg test = do
+withDirectoryServiceCfg tmp cfg = withDirectoryServiceCfgOwnersGroup tmp cfg False
+
+withDirectoryServiceCfgOwnersGroup :: HasCallStack => FilePath -> ChatConfig -> Bool -> (TestCC -> String -> IO ()) -> IO ()
+withDirectoryServiceCfgOwnersGroup tmp cfg createOwnersGroup test = do
   dsLink <-
     withNewTestChatCfg tmp cfg serviceDbPrefix directoryProfile $ \ds ->
       withNewTestChatCfg tmp cfg "super_user" aliceProfile $ \superUser -> do
         connectUsers ds superUser
+        when createOwnersGroup $ do
+          superUser ##> "/g owners"
+          superUser <## "group #owners is created"
+          superUser <## "to add members use /a owners <name> or /create link #owners"
+          superUser ##> "/a owners SimpleX-Directory admin"
+          superUser <## "invitation to join the group #owners sent to SimpleX-Directory"
+          ds <## "#owners: alice invites you to join the group as admin"
+          ds <## "use /j owners to accept"
+          ds ##> "/j owners"
+          ds <## "#owners: you joined the group"
+          superUser <## "#owners: SimpleX-Directory joined the group"
         ds ##> "/ad"
         getContactLink ds True
-  withDirectory tmp cfg dsLink test
+  withDirectoryOwnersGroup tmp cfg dsLink createOwnersGroup test
 
 restoreDirectoryService :: HasCallStack => FilePath -> Int -> Int -> (TestCC -> String -> IO ()) -> IO ()
 restoreDirectoryService tmp ctCount grCount test = do
@@ -1004,11 +1063,16 @@ restoreDirectoryService tmp ctCount grCount test = do
   withDirectory tmp testCfg dsLink test
 
 withDirectory :: HasCallStack => FilePath -> ChatConfig -> String -> (TestCC -> String -> IO ()) -> IO ()
-withDirectory tmp cfg dsLink test = do
-  let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"]
+withDirectory tmp cfg dsLink = withDirectoryOwnersGroup tmp cfg dsLink False
+
+withDirectoryOwnersGroup :: HasCallStack => FilePath -> ChatConfig -> String -> Bool -> (TestCC -> String -> IO ()) -> IO ()
+withDirectoryOwnersGroup tmp cfg dsLink createOwnersGroup test = do
+  let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"] $ if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing
   runDirectory cfg opts $
     withTestChatCfg tmp cfg "super_user" $ \superUser -> do
       superUser <## "1 contacts connected (use /cs for the list)"
+      when createOwnersGroup $
+        superUser <## "#owners: connected to server(s)"
       test superUser dsLink
 
 runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO ()