core chat groups protocol for adding members (#78)
* add category and local display name to group members, extend member status * additional chat commands, serialization * parse all chat messages * draft group protocol implementation * group protocol: connect new member to existing members (TODO fix race condition with contact connection) * send/receive group messages (race condition still there - the 3rd member cannot send either group or direct messages to the 2nd member - CONN SIMPLEX) * send x.grp.mem.info and x.ok in SMP confirmation * fix host user adding new member, update simplexmq to fix sqlite concurrency, remove logs, make # optional in chat commands * more precise view messages about members joining and connecting * track connection status; only send messages to active members (TODO change to current members); group name autocomplete after joining the group * track via which group the contact was added; show only one message when a contact fully connected; group tests * test sending messages to the new direct contacts created via the group * update simplexmq to include .cabal file * remove unused import
This commit is contained in:
Evgeny Poberezkin authored and 
GitHub committed
1 parent
94f89ed8f7
commit
189cd7e09d
14 files changed
+1262
-347
No files matched your search
+38
-11
@@ -7,6 +7,7 @@ module ChatClient where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM (retry)
|
||||
import Control.Exception (bracket_)
|
||||
import Control.Monad.Except
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatController (..))
|
||||
@@ -17,11 +18,8 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
||||
import qualified System.Terminal as C
|
||||
import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
|
||||
|
||||
testDB1 :: FilePath
|
||||
testDB1 = "tests/tmp/test1"
|
||||
|
||||
testDB2 :: FilePath
|
||||
testDB2 = "tests/tmp/test2"
|
||||
testDBPrefix :: FilePath
|
||||
testDBPrefix = "tests/tmp/test"
|
||||
|
||||
opts :: ChatOpts
|
||||
opts =
|
||||
@@ -50,10 +48,39 @@ virtualSimplexChat dbFile profile = do
|
||||
a <- async $ runSimplexChat cc
|
||||
pure (TestCC cc t a)
|
||||
|
||||
testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO ()
|
||||
testChatN ps test =
|
||||
bracket_
|
||||
(createDirectoryIfMissing False "tests/tmp")
|
||||
(removeDirectoryRecursive "tests/tmp")
|
||||
$ do
|
||||
let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..]
|
||||
tcs <- getTestCCs envs []
|
||||
test tcs
|
||||
where
|
||||
getTestCCs [] tcs = pure tcs
|
||||
getTestCCs ((p, db) : envs') tcs = (:) <$> virtualSimplexChat db p <*> getTestCCs envs' tcs
|
||||
|
||||
testChat2 :: Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat2 p1 p2 test = do
|
||||
createDirectoryIfMissing False "tests/tmp"
|
||||
tc1 <- virtualSimplexChat testDB1 p1
|
||||
tc2 <- virtualSimplexChat testDB2 p2
|
||||
test tc1 tc2
|
||||
removeDirectoryRecursive "tests/tmp"
|
||||
testChat2 p1 p2 test = testChatN [p1, p2] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2] = test tc1 tc2
|
||||
test_ _ = error "expected 2 chat clients"
|
||||
|
||||
testChat3 :: Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat3 p1 p2 p3 test = testChatN [p1, p2, p3] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2, tc3] = test tc1 tc2 tc3
|
||||
test_ _ = error "expected 3 chat clients"
|
||||
|
||||
testChat4 :: Profile -> Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat4 p1 p2 p3 p4 test = testChatN [p1, p2, p3, p4] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4
|
||||
test_ _ = error "expected 4 chat clients"
|
||||
|
||||
concurrentlyN_ :: [IO a] -> IO ()
|
||||
concurrentlyN_ = mapConcurrently_ id
|
||||
+148
-13
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChatTests where
|
||||
@@ -7,8 +8,9 @@ import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Concurrent.STM
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (dropWhileEnd, isPrefixOf)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Types (Profile (..))
|
||||
import Simplex.Chat.Types (Profile (..), User (..))
|
||||
import System.Terminal.Internal (VirtualTerminal (..))
|
||||
import Test.Hspec
|
||||
|
||||
@@ -18,12 +20,19 @@ aliceProfile = Profile {displayName = "alice", fullName = "Alice"}
|
||||
bobProfile :: Profile
|
||||
bobProfile = Profile {displayName = "bob", fullName = "Bob"}
|
||||
|
||||
cathProfile :: Profile
|
||||
cathProfile = Profile {displayName = "cath", fullName = "Catherine"}
|
||||
|
||||
danProfile :: Profile
|
||||
danProfile = Profile {displayName = "dan", fullName = "Daniel"}
|
||||
|
||||
chatTests :: Spec
|
||||
chatTests = do
|
||||
describe "direct messages" $
|
||||
it "add contact and send/receive message" testAddContact
|
||||
describe "chat groups" $
|
||||
describe "chat groups" $ do
|
||||
it "add contacts, create group and send/receive messages" testGroup
|
||||
it "create and join group with 4 members" testGroup2
|
||||
|
||||
testAddContact :: IO ()
|
||||
testAddContact =
|
||||
@@ -58,19 +67,133 @@ testAddContact =
|
||||
|
||||
testGroup :: IO ()
|
||||
testGroup =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
connectUsers alice bob
|
||||
alice #:> "/g #team"
|
||||
connectUsers alice cath
|
||||
alice #:> "/g team"
|
||||
-- TODO this occasionally fails in case getWindow is run before the command above is printed
|
||||
alice <## "use /a #team <name> to add members"
|
||||
alice ##> "/a #team bob admin"
|
||||
alice <## "use /a team <name> to add members"
|
||||
alice ##> "/a team bob"
|
||||
alice <## "invitation to join the group #team sent to bob"
|
||||
bob <## "use /j #team to accept"
|
||||
bob ##> "/j #team"
|
||||
bob <## "use /j team to accept"
|
||||
bob ##> "/j team"
|
||||
concurrently_
|
||||
(alice <## "bob joined the group #team")
|
||||
(bob <## "you joined the group #team")
|
||||
(alice <## "#team: bob joined the group")
|
||||
(bob <## "#team: you joined the group")
|
||||
alice ##> "/a team cath"
|
||||
alice <## "invitation to join the group #team sent to cath"
|
||||
cath <## "use /j team to accept"
|
||||
cath ##> "/j team"
|
||||
concurrentlyN_
|
||||
[ alice <## "#team: cath joined the group",
|
||||
do
|
||||
cath <## "#team: you joined the group"
|
||||
cath <## "#team: member bob (Bob) is connected",
|
||||
do
|
||||
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
|
||||
bob <## "#team: new member cath is connected"
|
||||
]
|
||||
alice #> "#team hello"
|
||||
concurrently_
|
||||
(bob <# "#team alice> hello")
|
||||
(cath <# "#team alice> hello")
|
||||
bob #> "#team hi there"
|
||||
concurrently_
|
||||
(alice <# "#team bob> hi there")
|
||||
(cath <# "#team bob> hi there")
|
||||
cath #> "#team hey"
|
||||
concurrently_
|
||||
(alice <# "#team cath> hey")
|
||||
(bob <# "#team cath> hey")
|
||||
bob #> "@cath hello cath"
|
||||
cath <# "bob> hello cath"
|
||||
cath #> "@bob hello bob"
|
||||
bob <# "cath> hello bob"
|
||||
|
||||
testGroup2 :: IO ()
|
||||
testGroup2 =
|
||||
testChat4 aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
connectUsers alice bob
|
||||
connectUsers alice cath
|
||||
connectUsers bob dan
|
||||
connectUsers alice dan
|
||||
alice #:> "/g club"
|
||||
-- TODO this occasionally fails in case getWindow is run before the command above is printed
|
||||
alice <## "use /a club <name> to add members"
|
||||
alice ##> "/a club bob"
|
||||
alice <## "invitation to join the group #club sent to bob"
|
||||
bob <## "use /j club to accept"
|
||||
alice ##> "/a club cath"
|
||||
alice <## "invitation to join the group #club sent to cath"
|
||||
cath <## "use /j club to accept"
|
||||
bob ##> "/j club"
|
||||
concurrently_
|
||||
(alice <## "#club: bob joined the group")
|
||||
(bob <## "#club: you joined the group")
|
||||
cath ##> "/j club"
|
||||
concurrentlyN_
|
||||
[ alice <## "#club: cath joined the group",
|
||||
do
|
||||
cath <## "#club: you joined the group"
|
||||
cath <## "#club: member bob (Bob) is connected",
|
||||
do
|
||||
bob <## "#club: alice added cath (Catherine) to the group (connecting...)"
|
||||
bob <## "#club: new member cath is connected"
|
||||
]
|
||||
bob ##> "/a club dan"
|
||||
bob <## "invitation to join the group #club sent to dan"
|
||||
dan <## "use /j club to accept"
|
||||
dan ##> "/j club"
|
||||
concurrentlyN_
|
||||
[ bob <## "#club: dan joined the group",
|
||||
do
|
||||
dan <## "#club: you joined the group"
|
||||
dan <### ["#club: member alice_1 (Alice) is connected", "#club: member cath (Catherine) is connected"],
|
||||
do
|
||||
alice <## "#club: bob added dan_1 (Daniel) to the group (connecting...)"
|
||||
alice <## "#club: new member dan_1 is connected",
|
||||
do
|
||||
cath <## "#club: bob added dan (Daniel) to the group (connecting...)"
|
||||
cath <## "#club: new member dan is connected"
|
||||
]
|
||||
alice #> "#club hello"
|
||||
concurrentlyN_
|
||||
[ bob <# "#club alice> hello",
|
||||
cath <# "#club alice> hello",
|
||||
dan <# "#club alice_1> hello"
|
||||
]
|
||||
bob #> "#club hi there"
|
||||
concurrentlyN_
|
||||
[ alice <# "#club bob> hi there",
|
||||
cath <# "#club bob> hi there",
|
||||
dan <# "#club bob> hi there"
|
||||
]
|
||||
cath #> "#club hey"
|
||||
concurrentlyN_
|
||||
[ alice <# "#club cath> hey",
|
||||
bob <# "#club cath> hey",
|
||||
dan <# "#club cath> hey"
|
||||
]
|
||||
dan #> "#club how is it going?"
|
||||
concurrentlyN_
|
||||
[ alice <# "#club dan_1> how is it going?",
|
||||
bob <# "#club dan> how is it going?",
|
||||
cath <# "#club dan> how is it going?"
|
||||
]
|
||||
bob #> "@cath hi cath"
|
||||
cath <# "bob> hi cath"
|
||||
cath #> "@bob hi bob"
|
||||
bob <# "cath> hi bob"
|
||||
dan #> "@cath hey cath"
|
||||
cath <# "dan> hey cath"
|
||||
cath #> "@dan hey dan"
|
||||
dan <# "cath> hey dan"
|
||||
dan #> "@alice_1 hi alice"
|
||||
alice <# "dan_1> hi alice"
|
||||
alice #> "@dan_1 hello dan"
|
||||
dan <# "alice_1> hello dan"
|
||||
|
||||
connectUsers :: TestCC -> TestCC -> IO ()
|
||||
connectUsers cc1 cc2 = do
|
||||
@@ -78,8 +201,12 @@ connectUsers cc1 cc2 = do
|
||||
Just inv <- invitation <$> getWindow cc1
|
||||
cc2 ##> ("/c " <> inv)
|
||||
concurrently_
|
||||
(cc2 <## "alice (Alice) is connected")
|
||||
(cc1 <## "bob (Bob) is connected")
|
||||
(cc2 <## (showName cc1 <> " is connected"))
|
||||
(cc1 <## (showName cc2 <> " is connected"))
|
||||
where
|
||||
showName :: TestCC -> String
|
||||
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _) =
|
||||
T.unpack $ localDisplayName <> " (" <> fullName <> ")"
|
||||
|
||||
(##>) :: TestCC -> String -> IO ()
|
||||
(##>) cc cmd = do
|
||||
@@ -97,6 +224,14 @@ connectUsers cc1 cc2 = do
|
||||
(<##) :: TestCC -> String -> Expectation
|
||||
cc <## line = (lastOutput <$> getWindow cc) `shouldReturn` line
|
||||
|
||||
(<###) :: TestCC -> [String] -> Expectation
|
||||
_ <### [] = pure ()
|
||||
cc <### ls = do
|
||||
line <- lastOutput <$> getWindow cc
|
||||
if line `elem` ls
|
||||
then cc <### filter (/= line) ls
|
||||
else error $ "unexpected output: " <> line
|
||||
|
||||
(<#) :: TestCC -> String -> Expectation
|
||||
cc <# line = (dropTime . lastOutput <$> getWindow cc) `shouldReturn` line
|
||||
|
||||
|
||||
Reference in new issue
Block a user