From 5353b466a99222208fe4ecdd6d6d113a017c6146 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 8 Aug 2023 16:06:56 +0100 Subject: [PATCH] directory: remove welcome when contact joins via group, member count in approval, chat commands via bot (#2872) * directory: remove welcome when contact joins via group, member count in approval, chat commands via bot * disable bot tests * rename command --- .../src/Directory/Events.hs | 6 +++ .../src/Directory/Service.hs | 24 ++++++++---- tests/Bots/DirectoryTests.hs | 38 ++++++++++++++----- 3 files changed, 52 insertions(+), 16 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 8ab6bea805..dab9ceb77e 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -90,6 +90,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser + DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser deriving instance Show (DirectoryCmdTag r) @@ -106,6 +107,7 @@ data DirectoryCmd (r :: DirectoryRole) where DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser + DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r @@ -127,12 +129,15 @@ directoryCmdP = "h" -> u DCHelp_ "confirm" -> u DCConfirmDuplicateGroup_ "list" -> u DCListUserGroups_ + "ls" -> u DCListUserGroups_ "delete" -> u DCDeleteGroup_ "approve" -> su DCApproveGroup_ "reject" -> su DCRejectGroup_ "suspend" -> su DCSuspendGroup_ "resume" -> su DCResumeGroup_ "last" -> su DCListLastGroups_ + "exec" -> su DCExecuteCommand_ + "x" -> su DCExecuteCommand_ _ -> fail "bad command tag" where u = pure . ADCT SDRUser @@ -151,5 +156,6 @@ directoryCmdP = DCSuspendGroup_ -> gc DCSuspendGroup DCResumeGroup_ -> gc DCResumeGroup DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10) + DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText) where gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ') diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 570aa57817..c33f42964e 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -17,7 +17,9 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad.Reader import qualified Data.ByteString.Char8 as B -import Data.Maybe (fromMaybe, maybeToList) +import Data.Time.Clock (getCurrentTime) +import Data.Time.LocalTime (getCurrentTimeZone) +import Data.Maybe (fromMaybe, isJust, maybeToList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -33,6 +35,7 @@ import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Types +import Simplex.Chat.View (serializeChatResponse) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) @@ -61,7 +64,7 @@ welcomeGetOpts = do pure opts directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO () -directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userId} cc = do +directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {userId} cc = do initializeBotAddress' (not testing) cc race_ (forever $ void getLine) . forever $ do (_, resp) <- atomically . readTBQueue $ outputQ cc @@ -131,7 +134,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI _ -> "Error joining group " <> displayName <> ", please re-send the invitation!" deContactConnected :: Contact -> IO () - deContactConnected ct = do + deContactConnected ct = unless (isJust $ viaGroup ct) $ do unless testing $ putStrLn $ T.unpack (localDisplayName' ct) <> " connected" sendMessage cc ct $ "Welcome to " <> serviceName <> " service!\n\ @@ -289,8 +292,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI 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:" + gr_ <- getGroupAndSummary cc dbGroupId + let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_ + text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ + <> "\n" <> groupInfoText p <> "\n" <> membersStr <> "\nTo approve send:" msg = maybe (MCText text) (\image -> MCImage {text, image}) image' withSuperUsers $ \cId -> do sendComposedMessage' cc cId Nothing msg @@ -391,7 +396,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI sendReply $ "Found " <> show (length gs) <> " group(s)" <> if length gs > 10 then ", sending 10." else "" void . forkIO $ forM_ (take 10 gs) $ \(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do - let membersStr = tshow currentMembers <> " members" + let membersStr = "_" <> tshow currentMembers <> " members_" text = groupInfoText p <> "\n" <> membersStr msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ sendComposedMessage cc ct Nothing msg @@ -483,6 +488,11 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI ct_ <- getContact cc dbContactId let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_ sendGroupInfo ct gr dbGroupId $ Just ownerStr + DCExecuteCommand cmdStr -> + sendChatCmdStr cc cmdStr >>= \r -> do + ts <- getCurrentTime + tz <- getCurrentTimeZone + sendReply $ serializeChatResponse (Just user) ts tz r DCCommandError tag -> sendReply $ "Command error: " <> show tag | otherwise = sendReply "You are not allowed to use this command" where @@ -504,7 +514,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI let statusStr = "Status: " <> groupRegStatusText grStatus getGroupAndSummary cc dbGroupId >>= \case Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do - let membersStr = tshow currentMembers <> " members" + let membersStr = "_" <> tshow currentMembers <> " members_" text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr] msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ sendComposedMessage cc ct Nothing msg diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index e074587ad5..d7eea3e35d 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -112,6 +112,9 @@ testDirectoryService tmp = superUser <# "SimpleX-Directory> The group ID 1 (PSA) is updated." approvalRequested superUser welcomeWithLink' (2 :: Int) -- putStrLn "*** try approving with the old registration code" + bob #> "@SimpleX-Directory /approve 1:PSA 1" + bob <# "SimpleX-Directory> > /approve 1:PSA 1" + bob <## " You are not allowed to use this command" superUser #> "@SimpleX-Directory /approve 1:PSA 1" superUser <# "SimpleX-Directory> > /approve 1:PSA 1" superUser <## " Incorrect approval code" @@ -138,6 +141,14 @@ testDirectoryService tmp = search bob "security" welcomeWithLink' cath `connectVia` dsLink search cath "privacy" welcomeWithLink' + bob #> "@SimpleX-Directory /exec /contacts" + bob <# "SimpleX-Directory> > /exec /contacts" + bob <## " You are not allowed to use this command" + superUser #> "@SimpleX-Directory /exec /contacts" + superUser <# "SimpleX-Directory> > /exec /contacts" + superUser <## " alice (Alice)" + superUser <## "bob (Bob)" + superUser <## "cath (Catherine)" where search u s welcome = do u #> ("@SimpleX-Directory " <> s) @@ -152,9 +163,11 @@ testDirectoryService tmp = u <## "description changed to:" u <## welcome approvalRequested su welcome grId = do - su <# "SimpleX-Directory> bob submitted the group ID 1: PSA (Privacy, Security & Anonymity)" + su <# "SimpleX-Directory> bob submitted the group ID 1:" + su <## "PSA (Privacy, Security & Anonymity)" su <## "Welcome message:" su <## welcome + su <## "2 members" su <## "" su <## "To approve send:" su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId) @@ -376,7 +389,7 @@ testRegOwnerChangedProfile tmp = cath <## "full name changed to: Privacy and Security" groupNotFound cath "privacy" superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." - reapproveGroup superUser bob + reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO () @@ -395,7 +408,7 @@ testAnotherOwnerChangedProfile tmp = bob <## "It is hidden from the directory until approved." groupNotFound cath "privacy" superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." - reapproveGroup superUser bob + reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO () @@ -428,7 +441,7 @@ testRegOwnerRemovedLink tmp = cath <## "bob updated group #privacy:" cath <## "description changed to:" cath <## welcomeWithLink - reapproveGroup superUser bob + reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO () @@ -470,7 +483,7 @@ testAnotherOwnerRemovedLink tmp = cath <## "bob updated group #privacy:" cath <## "description changed to:" cath <## (welcomeWithLink <> " - welcome!") - reapproveGroup superUser bob + reapproveGroup 3 superUser bob groupFoundN 3 cath "privacy" testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO () @@ -661,6 +674,9 @@ listGroups superUser bob cath = do cath <## "2 members" cath <## "Status: suspended because roles changed" -- superuser lists all groups + bob #> "@SimpleX-Directory /last" + bob <# "SimpleX-Directory> > /last" + bob <## " You are not allowed to use this command" superUser #> "@SimpleX-Directory /last" superUser <# "SimpleX-Directory> > /last" superUser <## " 3 registered group(s)" @@ -693,11 +709,13 @@ listGroups superUser bob cath = do superUser <## "2 members" superUser <## "Status: suspended because roles changed" -reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO () -reapproveGroup superUser bob = do - superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy (" +reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO () +reapproveGroup count superUser bob = do + superUser <# "SimpleX-Directory> bob submitted the group ID 1:" + superUser <##. "privacy (" superUser <## "Welcome message:" superUser <##. "Link to join the group privacy: " + superUser <## (show count <> " members") superUser <## "" superUser <## "To approve send:" superUser <# "SimpleX-Directory> /approve 1:privacy 1" @@ -804,9 +822,11 @@ updateProfileWithLink u n welcomeWithLink ugId = do notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () notifySuperUser su u n fn welcomeWithLink gId = do uName <- userName u - su <# ("SimpleX-Directory> " <> uName <> " submitted the group ID " <> show gId <> ": " <> n <> " (" <> fn <> ")") + su <# ("SimpleX-Directory> " <> uName <> " submitted the group ID " <> show gId <> ":") + su <## (n <> " (" <> fn <> ")") su <## "Welcome message:" su <## welcomeWithLink + su .<## "members" su <## "" su <## "To approve send:" let approve = "/approve " <> show gId <> ":" <> n <> " 1"