mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
directory service: additional commands (#5159)
* directory service: additional commands * notify superusers * 48 hours * replace T.elem
This commit is contained in:
Evgeny
GitHub
parent
7a741e7ac4
commit
2d588949b1
9 changed files with 259 additions and 164 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue