diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 4733dafb79..cedbd4fe34 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/apps/simplex-bot-advanced/Main.hs @@ -9,6 +9,7 @@ module Main where import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad +import Data.Text (Text) import qualified Data.Text as T import Simplex.Chat.Bot import Simplex.Chat.Controller @@ -18,6 +19,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Types +import Simplex.Messaging.Util (tshow) import System.Directory (getAppUserDataDirectory) import Text.Read @@ -34,7 +36,7 @@ welcomeGetOpts = do putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" pure opts -welcomeMessage :: String +welcomeMessage :: Text welcomeMessage = "Hello! I am a simple squaring bot.\nIf you send me a number, I will calculate its square" mySquaringBot :: User -> ChatController -> IO () @@ -47,10 +49,10 @@ mySquaringBot _user cc = do contactConnected contact sendMessage cc contact welcomeMessage CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do - let msg = T.unpack $ ciContentToText mc - number_ = readMaybe msg :: Maybe Integer + let msg = ciContentToText mc + number_ = readMaybe (T.unpack msg) :: Maybe Integer sendMessage cc contact $ case number_ of - Just n -> msg <> " * " <> msg <> " = " <> show (n * n) + Just n -> msg <> " * " <> msg <> " = " <> tshow (n * n) _ -> "\"" <> msg <> "\" is not a number" _ -> pure () where diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs index da021ee0b5..c526d64886 100644 --- a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs @@ -21,6 +21,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Types +import Simplex.Messaging.Util (tshow) import System.Directory (getAppUserDataDirectory) welcomeGetOpts :: IO BroadcastBotOpts @@ -48,14 +49,14 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u CRContactsList _ cts -> void . forkIO $ do let cts' = filter broadcastTo cts forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc - sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)" + sendReply $ "Forwarded to " <> tshow (length cts') <> " contact(s)" r -> putStrLn $ "Error getting contacts list: " <> show r else sendReply "!1 Message is not supported!" | otherwise -> do sendReply prohibitedMessage deleteMessage cc ct $ chatItemId' ci where - sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent + sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . MCText publisher = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} allowContent = \case MCText _ -> True diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Options.hs b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs index 57986874aa..5bc4ffef25 100644 --- a/apps/simplex-broadcast-bot/src/Broadcast/Options.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs @@ -7,6 +7,7 @@ module Broadcast.Options where import Data.Maybe (fromMaybe) +import Data.Text (Text) import Options.Applicative import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (updateStr, versionNumber, versionString) @@ -15,14 +16,14 @@ import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, coreC data BroadcastBotOpts = BroadcastBotOpts { coreOptions :: CoreChatOpts, publishers :: [KnownContact], - welcomeMessage :: String, - prohibitedMessage :: String + welcomeMessage :: Text, + prohibitedMessage :: Text } -defaultWelcomeMessage :: [KnownContact] -> String +defaultWelcomeMessage :: [KnownContact] -> Text defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> knownContactNames ps <> "." -defaultProhibitedMessage :: [KnownContact] -> String +defaultProhibitedMessage :: [KnownContact] -> Text defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> knownContactNames ps <> ". Your message is deleted." broadcastBotOpts :: FilePath -> FilePath -> Parser BroadcastBotOpts diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 3119815d7b..ce165a1344 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -89,10 +89,11 @@ crDirectoryEvent = \case CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors) _ -> Nothing -data DirectoryRole = DRUser | DRSuperUser +data DirectoryRole = DRUser | DRAdmin | DRSuperUser data SDirectoryRole (r :: DirectoryRole) where SDRUser :: SDirectoryRole 'DRUser + SDRAdmin :: SDirectoryRole 'DRAdmin SDRSuperUser :: SDirectoryRole 'DRSuperUser deriving instance Show (SDirectoryRole r) @@ -107,12 +108,14 @@ data DirectoryCmdTag (r :: DirectoryRole) where 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 + DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin + DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin + DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin + DCResumeGroup_ :: DirectoryCmdTag 'DRAdmin + DCListLastGroups_ :: DirectoryCmdTag 'DRAdmin + DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin + DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin + DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser deriving instance Show (DirectoryCmdTag r) @@ -130,12 +133,14 @@ data DirectoryCmd (r :: DirectoryRole) where 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 + DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin + DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin + DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin + DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin + DCListLastGroups :: Int -> DirectoryCmd 'DRAdmin + DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin + DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin + DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r @@ -168,17 +173,20 @@ directoryCmdP = "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_ + "approve" -> au DCApproveGroup_ + "reject" -> au DCRejectGroup_ + "suspend" -> au DCSuspendGroup_ + "resume" -> au DCResumeGroup_ + "last" -> au DCListLastGroups_ + "pending" -> au DCListPendingGroups_ + "link" -> au DCShowGroupLink_ + "owner" -> au DCSendToGroupOwner_ "exec" -> su DCExecuteCommand_ "x" -> su DCExecuteCommand_ _ -> fail "bad command tag" where u = pure . ADCT SDRUser + au = pure . ADCT SDRAdmin su = pure . ADCT SDRSuperUser cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r) cmdP = \case @@ -203,6 +211,11 @@ directoryCmdP = DCResumeGroup_ -> gc DCResumeGroup DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10) DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10) + DCShowGroupLink_ -> gc DCShowGroupLink + DCSendToGroupOwner_ -> do + (groupId, displayName) <- gc (,) + msg <- A.space *> A.takeText + pure $ DCSendToGroupOwner groupId displayName msg DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText) where gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP @@ -213,8 +226,8 @@ directoryCmdP = quoted c = A.char c *> takeNameTill (== c) <* A.char c refChar c = c > ' ' && c /= '#' && c /= '@' -viewName :: String -> String -viewName n = if ' ' `elem` n then "'" <> n <> "'" else n +viewName :: Text -> Text +viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n directoryCmdTag :: DirectoryCmd r -> Text directoryCmdTag = \case @@ -234,6 +247,8 @@ directoryCmdTag = \case DCResumeGroup {} -> "resume" DCListLastGroups _ -> "last" DCListPendingGroups _ -> "pending" + DCShowGroupLink {} -> "link" + DCSendToGroupOwner {} -> "owner" 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 0d64064d7d..7f02a580e6 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -11,6 +11,7 @@ module Directory.Options ) where +import qualified Data.Text as T import Options.Applicative import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (updateStr, versionNumber, versionString) @@ -18,9 +19,10 @@ import Simplex.Chat.Options (ChatOpts (..), ChatCmdLog (..), CoreChatOpts, coreC data DirectoryOpts = DirectoryOpts { coreOptions :: CoreChatOpts, + adminUsers :: [KnownContact], superUsers :: [KnownContact], directoryLog :: Maybe FilePath, - serviceName :: String, + serviceName :: T.Text, searchResults :: Int, testing :: Bool } @@ -28,6 +30,13 @@ data DirectoryOpts = DirectoryOpts directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts directoryOpts appDir defaultDbFileName = do coreOptions <- coreChatOptsP appDir defaultDbFileName + adminUsers <- + option + parseKnownContacts + ( long "admin-users" + <> metavar "ADMIN_USERS" + <> help "Comma-separated list of admin-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory" + ) superUsers <- option parseKnownContacts @@ -52,9 +61,10 @@ directoryOpts appDir defaultDbFileName = do pure DirectoryOpts { coreOptions, + adminUsers, superUsers, directoryLog, - serviceName, + serviceName = T.pack serviceName, searchResults = 10, testing = False } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index ba03642a28..c1012f2a0a 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -17,13 +17,11 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad -import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe, maybeToList) 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 @@ -37,6 +35,7 @@ import Simplex.Chat.Core import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) +import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) @@ -79,7 +78,7 @@ welcomeGetOpts = do pure opts directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO () -directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testing} user@User {userId} cc = do +directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults, testing} user@User {userId} cc = do initializeBotAddress' (not testing) cc env <- newServiceState race_ (forever $ void getLine) . forever $ do @@ -102,6 +101,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi logInfo $ "command received " <> directoryCmdTag cmd case sUser of SDRUser -> deUserCommand env ct ciId cmd + SDRAdmin -> deAdminCommand ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd DELogChatResponse r -> logInfo r where @@ -118,9 +118,9 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName userGroupReference' GroupReg {userGroupRegId} displayName = groupReference' userGroupRegId displayName groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = groupReference' groupId displayName - groupReference' groupId displayName = "ID " <> show groupId <> " (" <> T.unpack displayName <> ")" + groupReference' groupId displayName = "ID " <> tshow groupId <> " (" <> displayName <> ")" groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} = - T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name." + "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name." getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)]) getGroups = getGroups_ . Just @@ -151,7 +151,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do void $ addGroupReg st ct g GRSProposed r <- sendChatCmd cc $ APIJoinGroup groupId - sendMessage cc ct $ T.unpack $ case r of + sendMessage cc ct $ case r of CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…" _ -> "Error joining group " <> displayName <> ", please re-send the invitation!" @@ -179,10 +179,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi where askConfirmation = do ugrId <- addGroupReg st ct g GRSPendingConfirmation - sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:" - sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> viewName (T.unpack displayName) + sendMessage cc ct $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:" + sendMessage cc ct $ "/confirm " <> tshow ugrId <> ":" <> viewName displayName - badRolesMsg :: GroupRolesStatus -> Maybe String + badRolesMsg :: GroupRolesStatus -> Maybe Text badRolesMsg = \case GRSOk -> Nothing GRSServiceNotAdmin -> Just "You must grant directory service *admin* role to register the group" @@ -218,7 +218,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi when (ctId `isOwner` gr) $ do setGroupRegOwner st gr owner let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g - notifyOwner gr $ T.unpack $ "Joined the group " <> displayName <> ", creating the link…" + notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case CRGroupLinkCreated {connReqContact} -> do setGroupStatus st gr GRSPendingUpdate @@ -227,7 +227,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi "Created the public link to join the group via this directory service that is always online.\n\n\ \Please add it to the group welcome message.\n\ \For example, add:" - notifyOwner gr $ "Link to join the group " <> T.unpack displayName <> ": " <> B.unpack (strEncode $ simplexChatContact connReqContact) + notifyOwner gr $ "Link to join the group " <> displayName <> ": " <> strEncodeTxt (simplexChatContact connReqContact) CRChatCmdError _ (ChatError e) -> case e of CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin." CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group." @@ -256,7 +256,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr GPServiceLinkError -> do when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers." - logError $ "Error: no group link for " <> T.pack userGroupRef + logError $ "Error: no group link for " <> userGroupRef GRSPendingApproval n -> processProfileChange gr $ n + 1 GRSActive -> processProfileChange gr 1 GRSSuspended -> processProfileChange gr 1 @@ -277,7 +277,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi _ -> do let gaId = 1 setGroupStatus st gr $ GRSPendingApproval gaId - notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours." + notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 48 hours." checkRolesSendToApprove gr gaId processProfileChange gr n' = do setGroupStatus st gr GRSPendingUpdate @@ -299,13 +299,13 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved." notifySuperUsers $ "The group " <> groupRef <> " is updated." checkRolesSendToApprove gr n' - GPServiceLinkError -> logError $ "Error: no group link for " <> T.pack groupRef <> " pending approval." + GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval." groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) where profileUpdate = \case CRGroupLink {connReqContact} -> - let groupLink1 = safeDecodeUtf8 $ strEncode connReqContact - groupLink2 = safeDecodeUtf8 $ strEncode $ simplexChatContact connReqContact + let groupLink1 = strEncodeTxt connReqContact + groupLink2 = strEncodeTxt $ simplexChatContact connReqContact hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `isInfix` description p' in if @@ -331,7 +331,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi msg = maybe (MCText text) (\image -> MCImage {text, image}) image' withSuperUsers $ \cId -> do sendComposedMessage' cc cId Nothing msg - sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> viewName (T.unpack displayName) <> " " <> show gaId + sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do @@ -356,7 +356,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi where rStatus = groupRolesStatus contactRole serviceRole groupRef = groupReference g - ctRole = "*" <> B.unpack (strEncode contactRole) <> "*" + ctRole = "*" <> strEncodeTxt contactRole <> "*" suCtRole = "(user role is set to " <> ctRole <> ")." deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO () @@ -382,7 +382,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi _ -> pure () where groupRef = groupReference g - srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*" + srvRole = "*" <> strEncodeTxt serviceRole <> "*" suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")." whenContactIsOwner gr action = getGroupMember gr @@ -426,7 +426,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi <> serviceName <> " bot will create a public group link for the new members to join even when you are offline.\n\ \3. You will then need to add this link to the group welcome message.\n\ - \4. Once the link is added, service admins will approve the group (it can take up to 24 hours), and everybody will be able to find it in directory.\n\n\ + \4. Once the link is added, service admins will approve the group (it can take up to 48 hours), and everybody will be able to find it in directory.\n\n\ \Start from inviting the bot to your group as admin - it will guide you through the process" DCSearchGroup s -> withFoundListedGroups (Just s) $ sendSearchResults s DCSearchNext -> @@ -448,44 +448,47 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent DCSubmitGroup _link -> pure () DCConfirmDuplicateGroup ugrId gName -> - withUserGroupReg ugrId gName $ \gr g@GroupInfo {groupProfile = GroupProfile {displayName}} -> + withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr -> 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." + _ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation." DCListUserGroups -> atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do - sendReply $ show (length grs) <> " registered group(s)" + sendReply $ tshow (length grs) <> " registered group(s)" void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} -> sendGroupInfo ct gr userGroupRegId Nothing DCDeleteGroup ugrId gName -> - withUserGroupReg ugrId gName $ \gr GroupInfo {groupProfile = GroupProfile {displayName}} -> do + withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> 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)) + sendReply $ "Your group " <> displayName <> " is deleted from the directory" + DCSetRole gId gName mRole -> + (if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ + \GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do + gLink_ <- setGroupLinkRole cc groupId mRole + sendReply $ 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 *" <> strEncodeTxt mRole <> "*\n\n") + <> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink)) DCUnknownCommand -> sendReply "Unknown command" - DCCommandError tag -> sendReply $ "Command error: " <> show tag + DCCommandError tag -> sendReply $ "Command error: " <> tshow tag where + knownCt = knownContact ct + isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers withUserGroupReg ugrId gName action = atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case - Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Just gr@GroupReg {dbGroupId} -> do getGroup cc dbGroupId >>= \case - Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Nothing -> sendReply $ "Group ID " <> tshow 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 + | displayName == gName -> action g gr + | otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName + sendReply = mkSendReply ct ciId withFoundListedGroups s_ action = getGroups_ s_ >>= \case Just groups -> atomically (filterListedGroups st groups) >>= action @@ -495,8 +498,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi gs -> do let gs' = takeTop searchResults gs moreGroups = length gs - length gs' - more = if moreGroups > 0 then ", sending top " <> show (length gs') else "" - sendReply $ "Found " <> show (length gs) <> " group(s)" <> more <> "." + more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else "" + sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "." updateSearchRequest (STSearch s) $ groupIds gs' sendFoundGroups gs' moreGroups sendAllGroups takeFirst sortName searchType = \case @@ -504,8 +507,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi gs -> do let gs' = takeFirst searchResults gs moreGroups = length gs - length gs' - more = if moreGroups > 0 then ", sending " <> sortName <> " " <> show (length gs') else "" - sendReply $ show (length gs) <> " group(s) listed" <> more <> "." + more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else "" + sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "." updateSearchRequest searchType $ groupIds gs' sendFoundGroups gs' moreGroups sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case @@ -516,7 +519,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi let gs' = takeFirst searchResults $ filterNotSent sentGroups gs sentGroups' = sentGroups <> groupIds gs' moreGroups = length gs - S.size sentGroups' - sendReply $ "Sending " <> show (length gs') <> " more group(s)." + sendReply $ "Sending " <> tshow (length gs') <> " more group(s)." updateSearchRequest searchType sentGroups' sendFoundGroups gs' moreGroups updateSearchRequest :: SearchType -> Set GroupId -> IO () @@ -527,9 +530,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi sendFoundGroups gs moreGroups = void . forkIO $ do forM_ gs $ - \(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do + \(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do let membersStr = "_" <> tshow currentMembers <> " members_" - text = groupInfoText p <> "\n" <> membersStr + showId = if isAdmin then tshow groupId <> ". " else "" + text = showId <> groupInfoText p <> "\n" <> membersStr msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ sendComposedMessage cc ct Nothing msg when (moreGroups > 0) $ @@ -537,92 +541,134 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi MCText $ "Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)." - deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () - deSuperUserCommand ct ciId cmd - | superUser `elem` superUsers = case cmd of + deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () + deAdminCommand ct ciId cmd + | knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of DCApproveGroup {groupId, displayName = n, groupApprovalId} -> - getGroupAndReg groupId n >>= \case - Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." - Just (g, gr) -> - readTVarIO (groupRegStatus gr) >>= \case - GRSPendingApproval gaId - | gaId == groupApprovalId -> do - getDuplicateGroup g >>= \case - Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers." - Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." - _ -> do - getGroupRolesStatus g gr >>= \case - Just GRSOk -> do - setGroupStatus st gr GRSActive - sendReply "Group approved!" - notifyOwner gr $ "The group " <> userGroupReference' gr n <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved." - Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin - Just GRSContactNotOwner -> replyNotApproved "user is not an owner." - Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin - Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers." - where - replyNotApproved reason = sendReply $ "Group is not approved: " <> reason - serviceNotAdmin = serviceName <> " is not an admin." - | otherwise -> sendReply "Incorrect approval code" - _ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval." + withGroupAndReg sendReply groupId n $ \g gr -> + readTVarIO (groupRegStatus gr) >>= \case + GRSPendingApproval gaId + | gaId == groupApprovalId -> do + getDuplicateGroup g >>= \case + Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." + _ -> do + getGroupRolesStatus g gr >>= \case + Just GRSOk -> do + 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) + Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin + Just GRSContactNotOwner -> replyNotApproved "user is not an owner." + Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin + Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers." + where + replyNotApproved reason = sendReply $ "Group is not approved: " <> reason + serviceNotAdmin = serviceName <> " is not an admin." + | otherwise -> sendReply "Incorrect approval code" + _ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval." where groupRef = groupReference' groupId n DCRejectGroup _gaId _gName -> pure () DCSuspendGroup groupId gName -> do let groupRef = groupReference' groupId gName - getGroupAndReg groupId gName >>= \case - Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." - Just (_, gr) -> - readTVarIO (groupRegStatus gr) >>= \case - GRSActive -> do - setGroupStatus st gr GRSSuspended - notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators." - sendReply "Group suspended!" - _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended." + withGroupAndReg sendReply groupId gName $ \_ gr -> + readTVarIO (groupRegStatus gr) >>= \case + GRSActive -> do + setGroupStatus st gr GRSSuspended + let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" + notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators." + sendReply "Group suspended!" + notifyOtherSuperUsers $ suspended <> " by " <> viewName (localDisplayName' ct) + _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended." DCResumeGroup groupId gName -> do let groupRef = groupReference' groupId gName - getGroupAndReg groupId gName >>= \case - Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." - Just (_, gr) -> - readTVarIO (groupRegStatus gr) >>= \case - GRSSuspended -> do - setGroupStatus st gr GRSActive - 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." + withGroupAndReg sendReply groupId gName $ \_ gr -> + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspended -> do + setGroupStatus st gr GRSActive + let groupStr = "The group " <> userGroupReference' gr gName + notifyOwner gr $ groupStr <> " is listed in the directory again!" + sendReply "Group listing resumed!" + notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct) + _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." DCListLastGroups count -> listGroups count False DCListPendingGroups count -> listGroups count True - DCExecuteCommand cmdStr -> - sendChatCmdStr cc cmdStr >>= \r -> do - ts <- getCurrentTime - tz <- getCurrentTimeZone - sendReply $ serializeChatResponse (Nothing, Just user) ts tz Nothing r - DCCommandError tag -> sendReply $ "Command error: " <> show tag + DCShowGroupLink groupId gName -> do + let groupRef = groupReference' groupId gName + withGroupAndReg sendReply groupId gName $ \_ _ -> + sendChatCmd cc (APIGetGroupLink groupId) >>= \case + CRGroupLink {connReqContact, memberRole} -> + sendReply $ T.unlines + [ "The link to join the group " <> groupRef <> ":", + strEncodeTxt $ simplexChatContact connReqContact, + "New member role: " <> strEncodeTxt memberRole + ] + CRChatCmdError _ (ChatErrorStore (SEGroupLinkNotFound _)) -> + sendReply $ "The group " <> groupRef <> " has no public link." + r -> do + ts <- getCurrentTime + tz <- getCurrentTimeZone + let resp = T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r + sendReply $ "Unexpected error:\n" <> resp + DCSendToGroupOwner groupId gName msg -> do + 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 + DCCommandError tag -> sendReply $ "Command error: " <> tshow tag | otherwise = sendReply "You are not allowed to use this command" where - superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} - sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent + knownCt = knownContact ct + sendReply = mkSendReply ct ciId + notifyOtherSuperUsers s = withSuperUsers $ \ctId -> unless (ctId == contactId' ct) $ sendMessage' cc ctId s 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 "") + sendReply $ tshow (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> tshow 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 = - getGroup cc gId - $>>= \g@GroupInfo {groupProfile = GroupProfile {displayName}} -> - if displayName == gName - then - atomically (getGroupReg st gId) - $>>= \gr -> pure $ Just (g, gr) - else pure Nothing + deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () + deSuperUserCommand ct ciId cmd + | knownContact ct `elem` superUsers = case cmd of + DCExecuteCommand cmdStr -> + sendChatCmdStr cc cmdStr >>= \r -> do + ts <- getCurrentTime + tz <- getCurrentTimeZone + sendReply $ T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r + DCCommandError tag -> sendReply $ "Command error: " <> tshow tag + | otherwise = sendReply "You are not allowed to use this command" + where + sendReply = mkSendReply ct ciId + + knownContact :: Contact -> KnownContact + knownContact ct = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} + + mkSendReply :: Contact -> ChatItemId -> Text -> IO () + mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText + + withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () + withGroupAndReg sendReply gId gName action = + getGroup cc gId >>= \case + Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)" + Just g@GroupInfo {groupProfile = GroupProfile {displayName}} + | displayName == gName -> + atomically (getGroupReg st gId) >>= \case + Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)" + Just gr -> action g gr + | otherwise -> + sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName sendGroupInfo :: Contact -> GroupReg -> GroupId -> Maybe Text -> IO () sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do @@ -668,5 +714,8 @@ setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole CRGroupLink _ _ gLink _ -> Just gLink _ -> Nothing -unexpectedError :: String -> String +unexpectedError :: Text -> Text unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers." + +strEncodeTxt :: StrEncoding a => a -> Text +strEncodeTxt = safeDecodeUtf8 . strEncode diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 66479c0ee6..8c0978a98f 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -12,6 +12,7 @@ import Control.Concurrent.STM import Control.Monad import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) import qualified Data.Text as T import Simplex.Chat.Controller import Simplex.Chat.Core @@ -31,10 +32,10 @@ chatBotRepl welcome answer _user cc = do case resp of CRContactConnected _ contact _ -> do contactConnected contact - void $ sendMessage cc contact welcome + void $ sendMessage cc contact $ T.pack welcome CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do let msg = T.unpack $ ciContentToText mc - void $ sendMessage cc contact =<< answer contact msg + void $ sendMessage cc contact . T.pack =<< answer contact msg _ -> pure () where contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected" @@ -57,11 +58,11 @@ initializeBotAddress' logAddress cc = do when logAddress $ putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri) void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing} -sendMessage :: ChatController -> Contact -> String -> IO () -sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent +sendMessage :: ChatController -> Contact -> Text -> IO () +sendMessage cc ct = sendComposedMessage cc ct Nothing . MCText -sendMessage' :: ChatController -> ContactId -> String -> IO () -sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent +sendMessage' :: ChatController -> ContactId -> Text -> IO () +sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . MCText sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO () sendComposedMessage cc = sendComposedMessage' cc . contactId' @@ -83,9 +84,6 @@ deleteMessage cc ct chatItemId = do contactRef :: Contact -> ChatRef contactRef = ChatRef CTDirect . contactId' -textMsgContent :: String -> MsgContent -textMsgContent = MCText . T.pack - printLog :: ChatController -> ChatLogLevel -> String -> IO () printLog cc level s | logLevel (config cc) <= level = putStrLn s diff --git a/src/Simplex/Chat/Bot/KnownContacts.hs b/src/Simplex/Chat/Bot/KnownContacts.hs index 1ea44d49be..4555bb9fee 100644 --- a/src/Simplex/Chat/Bot/KnownContacts.hs +++ b/src/Simplex/Chat/Bot/KnownContacts.hs @@ -18,8 +18,8 @@ data KnownContact = KnownContact } deriving (Eq) -knownContactNames :: [KnownContact] -> String -knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName) +knownContactNames :: [KnownContact] -> Text +knownContactNames = T.intercalate ", " . map (("@" <>) . localDisplayName) parseKnownContacts :: ReadM [KnownContact] parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 3a3e9f889f..c50bb8b02d 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -10,7 +10,8 @@ import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (finally) import Control.Monad (forM_) -import Directory.Events (viewName) +import qualified Data.Text as T +import qualified Directory.Events as DE import Directory.Options import Directory.Service import Directory.Store @@ -27,7 +28,7 @@ import Test.Hspec hiding (it) directoryServiceTests :: SpecWith FilePath directoryServiceTests = do it "should register group" testDirectoryService - it "should suspend and resume group" testSuspendResume + it "should suspend and resume group, send message to owner" testSuspendResume it "should delete group registration" testDeleteGroup it "should change initial member role" testSetRole it "should join found group via link" testJoinGroup @@ -67,6 +68,7 @@ mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts mkDirectoryOpts tmp superUsers = DirectoryOpts { coreOptions = testCoreOpts {dbFilePrefix = tmp serviceDbPrefix}, + adminUsers = [], superUsers, directoryLog = Just $ tmp "directory_service.log", serviceName = "SimpleX-Directory", @@ -77,6 +79,9 @@ mkDirectoryOpts tmp superUsers = serviceDbPrefix :: FilePath serviceDbPrefix = "directory_service" +viewName :: String -> String +viewName = T.unpack . DE.viewName . T.pack + testDirectoryService :: HasCallStack => FilePath -> IO () testDirectoryService tmp = withDirectoryService tmp $ \superUser dsLink -> @@ -111,7 +116,7 @@ testDirectoryService tmp = -- putStrLn "*** update profile so that it has link" updateGroupProfile bob welcomeWithLink 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." + bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." approvalRequested superUser welcomeWithLink (1 :: Int) -- putStrLn "*** update profile so that it still has link" let welcomeWithLink' = "Welcome! " <> welcomeWithLink @@ -139,7 +144,7 @@ testDirectoryService tmp = -- putStrLn "*** update profile so that it has link again" updateGroupProfile bob welcomeWithLink' 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." + bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." approvalRequested superUser welcomeWithLink' (1 :: Int) superUser #> "@SimpleX-Directory /pending" superUser <# "SimpleX-Directory> > /pending" @@ -207,6 +212,17 @@ testSuspendResume tmp = superUser <## " Group listing resumed!" bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!" groupFound bob "privacy" + superUser #> "@SimpleX-Directory privacy" + groupFoundN_ (Just 1) 2 superUser "privacy" + superUser #> "@SimpleX-Directory /link 1:privacy" + superUser <# "SimpleX-Directory> > /link 1:privacy" + superUser <## " The link to join the group ID 1 (privacy):" + superUser <##. "https://simplex.chat/contact" + superUser <## "New member role: member" + superUser #> "@SimpleX-Directory /owner 1:privacy hello there" + superUser <# "SimpleX-Directory> > /owner 1:privacy hello there" + superUser <## " Forwarded to @bob, the owner of the group ID 1 (privacy)" + bob <# "SimpleX-Directory> hello there" testDeleteGroup :: HasCallStack => FilePath -> IO () testDeleteGroup tmp = @@ -650,7 +666,7 @@ testRegOwnerRemovedLink tmp = bob <## "description changed to:" bob <## welcomeWithLink bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) 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." + bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." cath <## "bob updated group #privacy:" cath <## "description changed to:" cath <## welcomeWithLink @@ -692,7 +708,7 @@ testAnotherOwnerRemovedLink tmp = bob <## "description changed to:" bob <## (welcomeWithLink <> " - welcome!") bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) 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." + bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours." cath <## "bob updated group #privacy:" cath <## "description changed to:" cath <## (welcomeWithLink <> " - welcome!") @@ -774,7 +790,7 @@ testDuplicateProhibitWhenUpdated tmp = cath ##> "/gp privacy security Security" cath <## "changed to #security (Security)" cath <# "SimpleX-Directory> Thank you! The group link for ID 2 (security) is added to the welcome message." - cath <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + cath <## "You will be notified once the group is added to the directory - it may take up to 48 hours." notifySuperUser superUser cath "security" "Security" welcomeWithLink' 2 approveRegistration superUser cath "security" 2 groupFound bob "security" @@ -1035,7 +1051,7 @@ updateProfileWithLink u n welcomeWithLink ugId = do u <## "description changed to:" u <## welcomeWithLink u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.") - u <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + u <## "You will be notified once the group is added to the directory - it may take up to 48 hours." notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () notifySuperUser su u n fn welcomeWithLink gId = do @@ -1112,10 +1128,13 @@ groupFoundN count u name = do groupFoundN' count u name groupFoundN' :: Int -> TestCC -> String -> IO () -groupFoundN' count u name = do +groupFoundN' = groupFoundN_ Nothing + +groupFoundN_ :: Maybe Int -> Int -> TestCC -> String -> IO () +groupFoundN_ shownId_ count u name = do u <# ("SimpleX-Directory> > " <> name) u <## " Found 1 group(s)." - u <#. ("SimpleX-Directory> " <> name) + u <#. ("SimpleX-Directory> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name) u <## "Welcome message:" u <##. "Link to join the group " u <## (show count <> " members")