mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-04-03 20:06:29 +00:00
189cd7e09d
* 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
87 lines
2.8 KiB
Haskell
87 lines
2.8 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
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 (..))
|
|
import Simplex.Chat.Options
|
|
import Simplex.Chat.Store
|
|
import Simplex.Chat.Types (Profile)
|
|
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
|
import qualified System.Terminal as C
|
|
import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
|
|
|
|
testDBPrefix :: FilePath
|
|
testDBPrefix = "tests/tmp/test"
|
|
|
|
opts :: ChatOpts
|
|
opts =
|
|
ChatOpts
|
|
{ dbFile = undefined,
|
|
smpServers = ["localhost:5223"]
|
|
}
|
|
|
|
termSettings :: VirtualTerminalSettings
|
|
termSettings =
|
|
VirtualTerminalSettings
|
|
{ virtualType = "xterm",
|
|
virtualWindowSize = pure C.Size {height = 24, width = 1000},
|
|
virtualEvent = retry,
|
|
virtualInterrupt = retry
|
|
}
|
|
|
|
data TestCC = TestCC ChatController VirtualTerminal (Async ())
|
|
|
|
virtualSimplexChat :: FilePath -> Profile -> IO TestCC
|
|
virtualSimplexChat dbFile profile = do
|
|
st <- createStore (dbFile <> ".chat.db") 1
|
|
void . runExceptT $ createUser st profile True
|
|
t <- withVirtualTerminal termSettings pure
|
|
cc <- newChatController opts {dbFile} t . const $ pure () -- no notifications
|
|
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 = 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
|