mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
SimpleX Directory Service (#2766)
* SimpleX Directory Service * more events * update events * fix * Apply suggestions from code review metavar Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * metavar 2 Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * process events * remove command serialization * update * update * process group profile update * basic group registration flow * search works * better messages * improve messages * test broadcast bot * test for directory service * better processing of group profile change, test * refactor * de-list group when owner or service is removed from the group, tests * fix: removing any member or any member leaving should not delist the group * refactor * more tests, fixes * disable bot tests in CI * remove comment --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
f0d64a30e9
commit
2b69103055
@@ -0,0 +1,76 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Bots.BroadcastTests where
|
||||
|
||||
import Broadcast.Bot
|
||||
import Broadcast.Options
|
||||
import ChatClient
|
||||
import ChatTests.Utils
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Exception (bracket)
|
||||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
|
||||
import Simplex.Chat.Types (Profile (..))
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec
|
||||
|
||||
broadcastBotTests :: SpecWith FilePath
|
||||
broadcastBotTests = do
|
||||
it "should broadcast message" testBroadcastMessages
|
||||
|
||||
withBroadcastBot :: BroadcastBotOpts -> IO () -> IO ()
|
||||
withBroadcastBot opts test =
|
||||
bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test)
|
||||
where
|
||||
bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts
|
||||
|
||||
broadcastBotProfile :: Profile
|
||||
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing}
|
||||
|
||||
mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts
|
||||
mkBotOpts tmp publishers =
|
||||
BroadcastBotOpts
|
||||
{ coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> botDbPrefix},
|
||||
publishers,
|
||||
welcomeMessage = defaultWelcomeMessage publishers,
|
||||
prohibitedMessage = defaultWelcomeMessage publishers
|
||||
}
|
||||
|
||||
botDbPrefix :: FilePath
|
||||
botDbPrefix = "broadcast_bot"
|
||||
|
||||
testBroadcastMessages :: HasCallStack => FilePath -> IO ()
|
||||
testBroadcastMessages tmp = do
|
||||
botLink <-
|
||||
withNewTestChat tmp botDbPrefix broadcastBotProfile $ \bc_bot ->
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
connectUsers bc_bot alice
|
||||
bc_bot ##> "/ad"
|
||||
getContactLink bc_bot True
|
||||
let botOpts = mkBotOpts tmp [KnownContact 2 "alice"]
|
||||
withBroadcastBot botOpts $
|
||||
withTestChat tmp "alice" $ \alice ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
bob `connectVia` botLink
|
||||
bob #> "@broadcast_bot hello"
|
||||
bob <# "broadcast_bot> > hello"
|
||||
bob <## " Hello! I am a broadcast bot."
|
||||
bob <## "I broadcast messages to all connected users from @alice."
|
||||
cath `connectVia` botLink
|
||||
alice #> "@broadcast_bot hello all!"
|
||||
bob <# "broadcast_bot> hello all!"
|
||||
cath <# "broadcast_bot> hello all!"
|
||||
alice <# "broadcast_bot> > hello all!"
|
||||
alice <## " Forwarded to 2 contact(s)"
|
||||
where
|
||||
cc `connectVia` botLink = do
|
||||
cc ##> ("/c " <> botLink)
|
||||
cc <## "connection request sent!"
|
||||
cc <## "broadcast_bot (Broadcast Bot): contact is connected"
|
||||
cc <# "broadcast_bot> Hello! I am a broadcast bot."
|
||||
cc <## "I broadcast messages to all connected users from @alice."
|
||||
@@ -0,0 +1,456 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
|
||||
module Bots.DirectoryTests where
|
||||
|
||||
import ChatClient
|
||||
import ChatTests.Utils
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Exception (finally)
|
||||
import Directory.Options
|
||||
import Directory.Service
|
||||
import Directory.Store
|
||||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
|
||||
import Simplex.Chat.Types (Profile (..), GroupMemberRole (GROwner))
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec
|
||||
|
||||
directoryServiceTests :: SpecWith FilePath
|
||||
directoryServiceTests = do
|
||||
it "should register group" testDirectoryService
|
||||
describe "de-listing the group" $ do
|
||||
it "should de-list if owner leaves the group" testDelistedOwnerLeaves
|
||||
it "should de-list if owner is removed from the group" testDelistedOwnerRemoved
|
||||
it "should NOT de-list if another member leaves the group" testNotDelistedMemberLeaves
|
||||
it "should NOT de-list if another member is removed from the group" testNotDelistedMemberRemoved
|
||||
it "should de-list if service is removed from the group" testDelistedServiceRemoved
|
||||
describe "should require re-approval if profile is changed by" $ do
|
||||
it "the registration owner" testRegOwnerChangedProfile
|
||||
it "another owner" testAnotherOwnerChangedProfile
|
||||
describe "should require profile update if group link is removed by " $ do
|
||||
it "the registration owner" testRegOwnerRemovedLink
|
||||
it "another owner" testAnotherOwnerRemovedLink
|
||||
|
||||
directoryProfile :: Profile
|
||||
directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
|
||||
|
||||
mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
|
||||
mkDirectoryOpts tmp superUsers =
|
||||
DirectoryOpts
|
||||
{ coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> serviceDbPrefix},
|
||||
superUsers,
|
||||
directoryLog = tmp </> "directory_service.log",
|
||||
serviceName = "SimpleX-Directory"
|
||||
}
|
||||
|
||||
serviceDbPrefix :: FilePath
|
||||
serviceDbPrefix = "directory_service"
|
||||
|
||||
testDirectoryService :: HasCallStack => FilePath -> IO ()
|
||||
testDirectoryService tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
bob #> "@SimpleX-Directory privacy"
|
||||
bob <# "SimpleX-Directory> > privacy"
|
||||
bob <## " No groups found"
|
||||
putStrLn "*** create a group"
|
||||
bob ##> "/g PSA Privacy, Security & Anonymity"
|
||||
bob <## "group #PSA (Privacy, Security & Anonymity) is created"
|
||||
bob <## "to add members use /a PSA <name> or /create link #PSA"
|
||||
bob ##> "/a PSA SimpleX-Directory member"
|
||||
bob <## "invitation to join the group #PSA sent to SimpleX-Directory"
|
||||
bob <# "SimpleX-Directory> You must grant directory service admin role to register the group"
|
||||
bob ##> "/mr PSA SimpleX-Directory admin"
|
||||
putStrLn "*** discover service joins group and creates the link for profile"
|
||||
bob <## "#PSA: you changed the role of SimpleX-Directory from member to admin"
|
||||
bob <# "SimpleX-Directory> Joining the group #PSA…"
|
||||
bob <## "#PSA: SimpleX-Directory joined the group"
|
||||
bob <# "SimpleX-Directory> Joined the group #PSA, creating the link…"
|
||||
bob <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online."
|
||||
bob <## ""
|
||||
bob <## "Please add it to the group welcome message."
|
||||
bob <## "For example, add:"
|
||||
welcomeWithLink <- dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine bob
|
||||
putStrLn "*** update profile without link"
|
||||
updateGroupProfile bob "Welcome!"
|
||||
bob <# "SimpleX-Directory> The profile updated for ID 1 (PSA), but the group link is not added to the welcome message."
|
||||
(superUser </)
|
||||
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."
|
||||
approvalRequested superUser welcomeWithLink (1 :: Int)
|
||||
putStrLn "*** update profile so that it still has link"
|
||||
let welcomeWithLink' = "Welcome! " <> welcomeWithLink
|
||||
updateGroupProfile bob welcomeWithLink'
|
||||
bob <# "SimpleX-Directory> The group ID 1 (PSA) is updated!"
|
||||
bob <## "It is hidden from the directory until approved."
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (PSA) is updated."
|
||||
approvalRequested superUser welcomeWithLink' (2 :: Int)
|
||||
putStrLn "*** try approving with the old registration code"
|
||||
superUser #> "@SimpleX-Directory /approve 1:PSA 1"
|
||||
superUser <# "SimpleX-Directory> > /approve 1:PSA 1"
|
||||
superUser <## " Incorrect approval code"
|
||||
putStrLn "*** update profile so that it has no link"
|
||||
updateGroupProfile bob "Welcome!"
|
||||
bob <# "SimpleX-Directory> The group link for ID 1 (PSA) is removed from the welcome message."
|
||||
bob <## ""
|
||||
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
|
||||
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (PSA), de-listed."
|
||||
superUser #> "@SimpleX-Directory /approve 1:PSA 2"
|
||||
superUser <# "SimpleX-Directory> > /approve 1:PSA 2"
|
||||
superUser <## " Error: the group ID 1 (PSA) is not pending approval."
|
||||
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."
|
||||
approvalRequested superUser welcomeWithLink' (1 :: Int)
|
||||
superUser #> "@SimpleX-Directory /approve 1:PSA 1"
|
||||
superUser <# "SimpleX-Directory> > /approve 1:PSA 1"
|
||||
superUser <## " Group approved!"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory!"
|
||||
bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
|
||||
search bob "privacy" welcomeWithLink'
|
||||
search bob "security" welcomeWithLink'
|
||||
cath `connectVia` dsLink
|
||||
search cath "privacy" welcomeWithLink'
|
||||
where
|
||||
search u s welcome = do
|
||||
u #> ("@SimpleX-Directory " <> s)
|
||||
u <# ("SimpleX-Directory> > " <> s)
|
||||
u <## " Found 1 group(s)"
|
||||
u <# "SimpleX-Directory> PSA (Privacy, Security & Anonymity)"
|
||||
u <## "Welcome message:"
|
||||
u <## welcome
|
||||
updateGroupProfile u welcome = do
|
||||
u ##> ("/set welcome #PSA " <> welcome)
|
||||
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 <## "Welcome message:"
|
||||
su <## welcome
|
||||
su <## ""
|
||||
su <## "To approve send:"
|
||||
su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId)
|
||||
|
||||
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedOwnerLeaves tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
leaveGroup "privacy" bob
|
||||
cath <## "#privacy: bob left the group"
|
||||
bob <# "SimpleX-Directory> You left the group ID 1 (privacy)."
|
||||
bob <## ""
|
||||
bob <## "Group is no longer listed in the directory."
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner left)."
|
||||
groupNotFound cath "privacy"
|
||||
|
||||
testDelistedOwnerRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedOwnerRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob ->
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
removeMember "privacy" cath bob
|
||||
bob <# "SimpleX-Directory> You are removed from the group ID 1 (privacy)."
|
||||
bob <## ""
|
||||
bob <## "Group is no longer listed in the directory."
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner is removed)."
|
||||
groupNotFound cath "privacy"
|
||||
|
||||
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
|
||||
testNotDelistedMemberLeaves tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
leaveGroup "privacy" cath
|
||||
bob <## "#privacy: cath left the group"
|
||||
(superUser </)
|
||||
groupFound cath "privacy"
|
||||
|
||||
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testNotDelistedMemberRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
removeMember "privacy" bob cath
|
||||
(superUser </)
|
||||
groupFound cath "privacy"
|
||||
|
||||
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
|
||||
testDelistedServiceRemoved tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
bob ##> "/rm #privacy SimpleX-Directory"
|
||||
bob <## "#privacy: you removed SimpleX-Directory from the group"
|
||||
cath <## "#privacy: bob removed SimpleX-Directory from the group"
|
||||
bob <# "SimpleX-Directory> SimpleX-Directory is removed from the group ID 1 (privacy)."
|
||||
bob <## ""
|
||||
bob <## "Group is no longer listed in the directory."
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)."
|
||||
groupNotFound cath "privacy"
|
||||
|
||||
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
|
||||
testRegOwnerChangedProfile tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
bob ##> "/gp privacy privacy Privacy and Security"
|
||||
bob <## "full name changed to: Privacy and Security"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!"
|
||||
bob <## "It is hidden from the directory until approved."
|
||||
cath <## "bob updated group #privacy:"
|
||||
cath <## "full name changed to: Privacy and Security"
|
||||
groupNotFound cath "privacy"
|
||||
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
|
||||
reapproveGroup superUser bob
|
||||
groupFound cath "privacy"
|
||||
|
||||
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
|
||||
testAnotherOwnerChangedProfile tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
cath ##> "/gp privacy privacy Privacy and Security"
|
||||
cath <## "full name changed to: Privacy and Security"
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "full name changed to: Privacy and Security"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!"
|
||||
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
|
||||
groupFound cath "privacy"
|
||||
|
||||
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
|
||||
testRegOwnerRemovedLink tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
bob ##> "/show welcome #privacy"
|
||||
bob <## "Welcome message:"
|
||||
welcomeWithLink <- getTermLine bob
|
||||
bob ##> "/set welcome #privacy Welcome!"
|
||||
bob <## "description changed to:"
|
||||
bob <## "Welcome!"
|
||||
bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message."
|
||||
bob <## ""
|
||||
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
|
||||
cath <## "bob updated group #privacy:"
|
||||
cath <## "description changed to:"
|
||||
cath <## "Welcome!"
|
||||
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed."
|
||||
groupNotFound cath "privacy"
|
||||
bob ##> ("/set welcome #privacy " <> welcomeWithLink)
|
||||
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."
|
||||
cath <## "bob updated group #privacy:"
|
||||
cath <## "description changed to:"
|
||||
cath <## welcomeWithLink
|
||||
reapproveGroup superUser bob
|
||||
groupFound cath "privacy"
|
||||
|
||||
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
|
||||
testAnotherOwnerRemovedLink tmp =
|
||||
withDirectoryService tmp $ \superUser dsLink ->
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
addCathAsOwner bob cath
|
||||
bob ##> "/show welcome #privacy"
|
||||
bob <## "Welcome message:"
|
||||
welcomeWithLink <- getTermLine bob
|
||||
cath ##> "/set welcome #privacy Welcome!"
|
||||
cath <## "description changed to:"
|
||||
cath <## "Welcome!"
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description changed to:"
|
||||
bob <## "Welcome!"
|
||||
bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message."
|
||||
bob <## ""
|
||||
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
|
||||
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed."
|
||||
groupNotFound cath "privacy"
|
||||
cath ##> ("/set welcome #privacy " <> welcomeWithLink)
|
||||
cath <## "description changed to:"
|
||||
cath <## welcomeWithLink
|
||||
bob <## "cath updated group #privacy:"
|
||||
bob <## "description changed to:"
|
||||
bob <## welcomeWithLink
|
||||
bob <# "SimpleX-Directory> The group link is added by another group member, your registration will not be processed."
|
||||
bob <## ""
|
||||
bob <## "Please update the group profile yourself."
|
||||
bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!")
|
||||
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."
|
||||
cath <## "bob updated group #privacy:"
|
||||
cath <## "description changed to:"
|
||||
cath <## (welcomeWithLink <> " - welcome!")
|
||||
reapproveGroup superUser bob
|
||||
groupFound cath "privacy"
|
||||
|
||||
reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
reapproveGroup superUser bob = do
|
||||
superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy ("
|
||||
superUser <## "Welcome message:"
|
||||
superUser <##. "Link to join the group privacy: "
|
||||
superUser <## ""
|
||||
superUser <## "To approve send:"
|
||||
superUser <# "SimpleX-Directory> /approve 1:privacy 1"
|
||||
superUser #> "@SimpleX-Directory /approve 1:privacy 1"
|
||||
superUser <# "SimpleX-Directory> > /approve 1:privacy 1"
|
||||
superUser <## " Group approved!"
|
||||
bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory!"
|
||||
bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
|
||||
|
||||
addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
addCathAsOwner bob cath = do
|
||||
connectUsers bob cath
|
||||
fullAddMember "privacy" "Privacy" bob cath GROwner
|
||||
joinGroup "privacy" cath bob
|
||||
cath <## "#privacy: member SimpleX-Directory is connected"
|
||||
|
||||
withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ()) -> IO ()
|
||||
withDirectoryService tmp test = do
|
||||
dsLink <-
|
||||
withNewTestChat tmp serviceDbPrefix directoryProfile $ \ds ->
|
||||
withNewTestChat tmp "super_user" aliceProfile $ \superUser -> do
|
||||
connectUsers ds superUser
|
||||
ds ##> "/ad"
|
||||
getContactLink ds True
|
||||
let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"]
|
||||
withDirectory opts $
|
||||
withTestChat tmp "super_user" $ \superUser -> do
|
||||
superUser <## "1 contacts connected (use /cs for the list)"
|
||||
test superUser dsLink
|
||||
where
|
||||
withDirectory :: DirectoryOpts -> IO () -> IO ()
|
||||
withDirectory opts@DirectoryOpts {directoryLog} action = do
|
||||
st <- getDirectoryStore directoryLog
|
||||
t <- forkIO $ bot st
|
||||
threadDelay 500000
|
||||
action `finally` killThread t
|
||||
where
|
||||
bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
|
||||
|
||||
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
|
||||
registerGroup su u n fn = do
|
||||
u ##> ("/g " <> n <> " " <> fn)
|
||||
u <## ("group #" <> n <> " (" <> fn <> ") is created")
|
||||
u <## ("to add members use /a " <> n <> " <name> or /create link #" <> n)
|
||||
u ##> ("/a " <> n <> " SimpleX-Directory admin")
|
||||
u <## ("invitation to join the group #" <> n <> " sent to SimpleX-Directory")
|
||||
u <# ("SimpleX-Directory> Joining the group #" <> n <> "…")
|
||||
u <## ("#" <> n <> ": SimpleX-Directory joined the group")
|
||||
u <# ("SimpleX-Directory> Joined the group #" <> n <> ", creating the link…")
|
||||
u <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online."
|
||||
u <## ""
|
||||
u <## "Please add it to the group welcome message."
|
||||
u <## "For example, add:"
|
||||
welcomeWithLink <- dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u
|
||||
u ##> ("/set welcome " <> n <> " " <> welcomeWithLink)
|
||||
u <## "description changed to:"
|
||||
u <## welcomeWithLink
|
||||
u <# ("SimpleX-Directory> Thank you! The group link for ID 1 (" <> 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."
|
||||
su <# ("SimpleX-Directory> bob submitted the group ID 1: " <> n <> " (" <> fn <> ")")
|
||||
su <## "Welcome message:"
|
||||
su <## welcomeWithLink
|
||||
su <## ""
|
||||
su <## "To approve send:"
|
||||
let approve = "/approve 1:" <> n <> " 1"
|
||||
su <# ("SimpleX-Directory> " <> approve)
|
||||
su #> ("@SimpleX-Directory " <> approve)
|
||||
su <# ("SimpleX-Directory> > " <> approve)
|
||||
su <## " Group approved!"
|
||||
u <# ("SimpleX-Directory> The group ID 1 (" <> n <> ") is approved and listed in directory!")
|
||||
u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
|
||||
|
||||
connectVia :: TestCC -> String -> IO ()
|
||||
u `connectVia` dsLink = do
|
||||
u ##> ("/c " <> dsLink)
|
||||
u <## "connection request sent!"
|
||||
u <## "SimpleX-Directory: contact is connected"
|
||||
u <# "SimpleX-Directory> Welcome to SimpleX-Directory service!"
|
||||
u <## "Send a search string to find groups or /help to learn how to add groups to directory."
|
||||
u <## ""
|
||||
u <## "For example, send privacy to find groups about privacy."
|
||||
|
||||
joinGroup :: String -> TestCC -> TestCC -> IO ()
|
||||
joinGroup gName member host = do
|
||||
let gn = "#" <> gName
|
||||
memberName <- userName member
|
||||
hostName <- userName host
|
||||
member ##> ("/j " <> gName)
|
||||
member <## (gn <> ": you joined the group")
|
||||
member <#. (gn <> " " <> hostName <> "> Link to join the group " <> gName <> ": ")
|
||||
host <## (gn <> ": " <> memberName <> " joined the group")
|
||||
|
||||
leaveGroup :: String -> TestCC -> IO ()
|
||||
leaveGroup gName member = do
|
||||
let gn = "#" <> gName
|
||||
member ##> ("/l " <> gName)
|
||||
member <## (gn <> ": you left the group")
|
||||
member <## ("use /d " <> gn <> " to delete the group")
|
||||
|
||||
removeMember :: String -> TestCC -> TestCC -> IO ()
|
||||
removeMember gName admin removed = do
|
||||
let gn = "#" <> gName
|
||||
adminName <- userName admin
|
||||
removedName <- userName removed
|
||||
admin ##> ("/rm " <> gName <> " " <> removedName)
|
||||
admin <## (gn <> ": you removed " <> removedName <> " from the group")
|
||||
removed <## (gn <> ": " <> adminName <> " removed you from the group")
|
||||
removed <## ("use /d " <> gn <> " to delete the group")
|
||||
|
||||
groupFound :: TestCC -> String -> IO ()
|
||||
groupFound u s = do
|
||||
u #> ("@SimpleX-Directory " <> s)
|
||||
u <# ("SimpleX-Directory> > " <> s)
|
||||
u <## " Found 1 group(s)"
|
||||
u <#. "SimpleX-Directory> privacy ("
|
||||
u <## "Welcome message:"
|
||||
u <##. "Link to join the group privacy: "
|
||||
|
||||
groupNotFound :: TestCC -> String -> IO ()
|
||||
groupNotFound u s = do
|
||||
u #> ("@SimpleX-Directory " <> s)
|
||||
u <# ("SimpleX-Directory> > " <> s)
|
||||
u <## " No groups found"
|
||||
@@ -48,9 +48,15 @@ xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
|
||||
xit' = if os == "linux" then xit else it
|
||||
|
||||
xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
|
||||
xit'' d t = do
|
||||
xit'' = ifCI xit it
|
||||
|
||||
xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a
|
||||
xdescribe'' = ifCI xdescribe describe
|
||||
|
||||
ifCI :: HasCallStack => (HasCallStack => String -> a -> SpecWith b) -> (HasCallStack => String -> a -> SpecWith b) -> String -> a -> SpecWith b
|
||||
ifCI xrun run d t = do
|
||||
ci <- runIO $ lookupEnv "CI"
|
||||
(if ci == Just "true" then xit else it) d t
|
||||
(if ci == Just "true" then xrun else run) d t
|
||||
|
||||
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
versionTestMatrix2 runTest = do
|
||||
@@ -349,6 +355,11 @@ dropTime_ msg = case splitAt 6 msg of
|
||||
if all isDigit [m, m', s, s'] then Just text else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
dropStrPrefix :: HasCallStack => String -> String -> String
|
||||
dropStrPrefix pfx s =
|
||||
let (p, rest) = splitAt (length pfx) s
|
||||
in if p == pfx then rest else error $ "no prefix " <> pfx <> " in string : " <> s
|
||||
|
||||
dropReceipt :: HasCallStack => String -> String
|
||||
dropReceipt msg = fromMaybe err $ dropReceipt_ msg
|
||||
where
|
||||
@@ -475,14 +486,18 @@ createGroup3 gName cc1 cc2 cc3 = do
|
||||
]
|
||||
|
||||
addMember :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
||||
addMember gName inviting invitee role = do
|
||||
addMember gName = fullAddMember gName ""
|
||||
|
||||
fullAddMember :: HasCallStack => String -> String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
||||
fullAddMember gName fullName inviting invitee role = do
|
||||
name1 <- userName inviting
|
||||
memName <- userName invitee
|
||||
inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role))
|
||||
let fullName' = if null fullName || fullName == gName then "" else " (" <> fullName <> ")"
|
||||
concurrentlyN_
|
||||
[ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName),
|
||||
do
|
||||
invitee <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
|
||||
invitee <## ("#" <> gName <> fullName' <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
|
||||
invitee <## ("use /j " <> gName <> " to accept")
|
||||
]
|
||||
|
||||
|
||||
@@ -1,5 +1,8 @@
|
||||
import Bots.BroadcastTests
|
||||
import Bots.DirectoryTests
|
||||
import ChatClient
|
||||
import ChatTests
|
||||
import ChatTests.Utils (xdescribe'')
|
||||
import Control.Logger.Simple
|
||||
import Data.Time.Clock.System
|
||||
import MarkdownTests
|
||||
@@ -23,6 +26,8 @@ main = do
|
||||
around testBracket $ do
|
||||
describe "Mobile API Tests" mobileTests
|
||||
describe "SimpleX chat client" chatTests
|
||||
xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
|
||||
xdescribe'' "SimpleX Directory service bot" directoryServiceTests
|
||||
where
|
||||
testBracket test = do
|
||||
t <- getSystemTime
|
||||
|
||||
Reference in New Issue
Block a user