IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

directory: remove welcome when contact joins via group, member count in approval, chat commands via bot (#2872)

Browse Source 
* directory: remove welcome when contact joins via group, member count in approval, chat commands via bot

* disable bot tests

* rename command
This commit is contained in:
Evgeny Poberezkin
2023-08-08 16:06:56 +01:00
committed by GitHub
parent b28a51106f
commit 5353b466a9
3 changed files with 52 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
apps/simplex-directory-service/src/Directory/Events.hs
View File

@@ -90,6 +90,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
@@ -106,6 +107,7 @@ data DirectoryCmd (r :: DirectoryRole) where
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -127,12 +129,15 @@ directoryCmdP =
"h" -> u DCHelp_
"confirm" -> u DCConfirmDuplicateGroup_
"list" -> u DCListUserGroups_
"ls" -> u DCListUserGroups_
"delete" -> u DCDeleteGroup_
"approve" -> su DCApproveGroup_
"reject" -> su DCRejectGroup_
"suspend" -> su DCSuspendGroup_
"resume" -> su DCResumeGroup_
"last" -> su DCListLastGroups_
"exec" -> su DCExecuteCommand_
"x" -> su DCExecuteCommand_
_ -> fail "bad command tag"
where
u = pure . ADCT SDRUser
@@ -151,5 +156,6 @@ directoryCmdP =
DCSuspendGroup_ -> gc DCSuspendGroup
DCResumeGroup_ -> gc DCResumeGroup
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ')

24
apps/simplex-directory-service/src/Directory/Service.hs
View File

@@ -17,7 +17,9 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, maybeToList)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Data.Maybe (fromMaybe, isJust, maybeToList)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
@@ -33,6 +35,7 @@ import Simplex.Chat.Messages
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import Simplex.Chat.View (serializeChatResponse)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>))
import System.Directory (getAppUserDataDirectory)
@@ -61,7 +64,7 @@ welcomeGetOpts = do
pure opts
directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userId} cc = do
directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {userId} cc = do
initializeBotAddress' (not testing) cc
race_ (forever $ void getLine) . forever $ do
(_, resp) <- atomically . readTBQueue $ outputQ cc
@@ -131,7 +134,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI
_ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
deContactConnected :: Contact -> IO ()
deContactConnected ct = do
deContactConnected ct = unless (isJust $ viaGroup ct) $ do
unless testing $ putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
sendMessage cc ct $
"Welcome to " <> serviceName <> " service!\n\
@@ -289,8 +292,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI
sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO ()
sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do
ct_ <- getContact cc dbContactId
let text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_
<> groupInfoText p <> "\n\nTo approve send:"
gr_ <- getGroupAndSummary cc dbGroupId
let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_
text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_
<> "\n" <> groupInfoText p <> "\n" <> membersStr <> "\nTo approve send:"
msg = maybe (MCText text) (\image -> MCImage {text, image}) image'
withSuperUsers $ \cId -> do
sendComposedMessage' cc cId Nothing msg
@@ -391,7 +396,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI
sendReply $ "Found " <> show (length gs) <> " group(s)" <> if length gs > 10 then ", sending 10." else ""
void . forkIO $ forM_ (take 10 gs) $
\(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = tshow currentMembers <> " members"
let membersStr = "_" <> tshow currentMembers <> " members_"
text = groupInfoText p <> "\n" <> membersStr
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
@@ -483,6 +488,11 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI
ct_ <- getContact cc dbContactId
let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_
sendGroupInfo ct gr dbGroupId $ Just ownerStr
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
sendReply $ serializeChatResponse (Just user) ts tz r
DCCommandError tag -> sendReply $ "Command error: " <> show tag
| otherwise = sendReply "You are not allowed to use this command"
where
@@ -504,7 +514,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userI
let statusStr = "Status: " <> groupRegStatusText grStatus
getGroupAndSummary cc dbGroupId >>= \case
Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = tshow currentMembers <> " members"
let membersStr = "_" <> tshow currentMembers <> " members_"
text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr]
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg

38
tests/Bots/DirectoryTests.hs
View File

@@ -112,6 +112,9 @@ testDirectoryService tmp =
superUser <# "SimpleX-Directory> The group ID 1 (PSA) is updated."
approvalRequested superUser welcomeWithLink' (2 :: Int)
-- putStrLn "*** try approving with the old registration code"
bob #> "@SimpleX-Directory /approve 1:PSA 1"
bob <# "SimpleX-Directory> > /approve 1:PSA 1"
bob <## " You are not allowed to use this command"
superUser #> "@SimpleX-Directory /approve 1:PSA 1"
superUser <# "SimpleX-Directory> > /approve 1:PSA 1"
superUser <## " Incorrect approval code"
@@ -138,6 +141,14 @@ testDirectoryService tmp =
search bob "security" welcomeWithLink'
cath `connectVia` dsLink
search cath "privacy" welcomeWithLink'
bob #> "@SimpleX-Directory /exec /contacts"
bob <# "SimpleX-Directory> > /exec /contacts"
bob <## " You are not allowed to use this command"
superUser #> "@SimpleX-Directory /exec /contacts"
superUser <# "SimpleX-Directory> > /exec /contacts"
superUser <## " alice (Alice)"
superUser <## "bob (Bob)"
superUser <## "cath (Catherine)"
where
search u s welcome = do
u #> ("@SimpleX-Directory " <> s)
@@ -152,9 +163,11 @@ testDirectoryService tmp =
u <## "description changed to:"
u <## welcome
approvalRequested su welcome grId = do
su <# "SimpleX-Directory> bob submitted the group ID 1: PSA (Privacy, Security & Anonymity)"
su <# "SimpleX-Directory> bob submitted the group ID 1:"
su <## "PSA (Privacy, Security & Anonymity)"
su <## "Welcome message:"
su <## welcome
su <## "2 members"
su <## ""
su <## "To approve send:"
su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId)
@@ -376,7 +389,7 @@ testRegOwnerChangedProfile tmp =
cath <## "full name changed to: Privacy and Security"
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
reapproveGroup 3 superUser bob
groupFoundN 3 cath "privacy"
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
@@ -395,7 +408,7 @@ testAnotherOwnerChangedProfile tmp =
bob <## "It is hidden from the directory until approved."
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
reapproveGroup 3 superUser bob
groupFoundN 3 cath "privacy"
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
@@ -428,7 +441,7 @@ testRegOwnerRemovedLink tmp =
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## welcomeWithLink
reapproveGroup superUser bob
reapproveGroup 3 superUser bob
groupFoundN 3 cath "privacy"
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
@@ -470,7 +483,7 @@ testAnotherOwnerRemovedLink tmp =
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!")
reapproveGroup superUser bob
reapproveGroup 3 superUser bob
groupFoundN 3 cath "privacy"
testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO ()
@@ -661,6 +674,9 @@ listGroups superUser bob cath = do
cath <## "2 members"
cath <## "Status: suspended because roles changed"
-- superuser lists all groups
bob #> "@SimpleX-Directory /last"
bob <# "SimpleX-Directory> > /last"
bob <## " You are not allowed to use this command"
superUser #> "@SimpleX-Directory /last"
superUser <# "SimpleX-Directory> > /last"
superUser <## " 3 registered group(s)"
@@ -693,11 +709,13 @@ listGroups superUser bob cath = do
superUser <## "2 members"
superUser <## "Status: suspended because roles changed"
reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO ()
reapproveGroup superUser bob = do
superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy ("
reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO ()
reapproveGroup count superUser bob = do
superUser <# "SimpleX-Directory> bob submitted the group ID 1:"
superUser <##. "privacy ("
superUser <## "Welcome message:"
superUser <##. "Link to join the group privacy: "
superUser <## (show count <> " members")
superUser <## ""
superUser <## "To approve send:"
superUser <# "SimpleX-Directory> /approve 1:privacy 1"
@@ -804,9 +822,11 @@ updateProfileWithLink u n welcomeWithLink ugId = do
notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
notifySuperUser su u n fn welcomeWithLink gId = do
uName <- userName u
su <# ("SimpleX-Directory> " <> uName <> " submitted the group ID " <> show gId <> ": " <> n <> " (" <> fn <> ")")
su <# ("SimpleX-Directory> " <> uName <> " submitted the group ID " <> show gId <> ":")
su <## (n <> " (" <> fn <> ")")
su <## "Welcome message:"
su <## welcomeWithLink
su .<## "members"
su <## ""
su <## "To approve send:"
let approve = "/approve " <> show gId <> ":" <> n <> " 1"