diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index ce165a1344..19c9405358 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/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" diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 3017f82c8c..a62939b6ac 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/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, diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 102fe4cf7e..2db7857928 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/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 diff --git a/src/Simplex/Chat/Bot/KnownContacts.hs b/src/Simplex/Chat/Bot/KnownContacts.hs index 4555bb9fee..644b744437 100644 --- a/src/Simplex/Chat/Bot/KnownContacts.hs +++ b/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} diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 799c4ea1fc..834599a70f 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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 diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 8c332f9902..8613c7f892 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/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 }, diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 0aa508994a..6cb11f3f93 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/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 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 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 ()