dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 16:25:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

TMVar lock to avoid subscriber and client processing in parallel, fix the test (#90)

Browse Source 
* TMVar lock to avoid subscriber and client processing in parallel, fix the test

* run SMP server as part of the test

* stabilize tests

* update simplexmq

* test: stabilize getting invitation from terminal

* remove unused import

* simplify test
This commit is contained in:
Evgeny Poberezkin
2021-08-05 20:51:48 +01:00
committed by GitHub
parent a9d32db404
commit d23417596e
7 changed files with 243 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
package.yaml
View File

@@ -58,6 +58,7 @@ tests:
- simplex-chat
- async == 2.2.*
- hspec == 2.7.*
- network == 3.1.*
- stm == 2.5.*
ghc-options:

18
src/Simplex/Chat.hs
View File

@@ -50,6 +50,7 @@ import System.Exit (exitFailure, exitSuccess)
import System.IO (hFlush, stdout)
import Text.Read (readMaybe)
import UnliftIO.Async (race_)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
data ChatCommand
@@ -111,7 +112,8 @@ newChatController ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {
idsDrg <- newTVarIO =<< drgNew
inputQ <- newTBQueueIO tbqSize
notifyQ <- newTBQueueIO tbqSize
pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, idsDrg, inputQ, notifyQ, sendNotification}
chatLock <- newTMVarIO ()
pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, idsDrg, inputQ, notifyQ, sendNotification, chatLock}
runSimplexChat :: ChatController -> IO ()
runSimplexChat = runReaderT (race_ runTerminalInput runChatController)
@@ -124,9 +126,16 @@ runChatController =
notificationSubscriber
]
withLock :: MonadUnliftIO m => TMVar () -> m () -> m ()
withLock lock =
E.bracket_
(void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ())
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
inputSubscriber = do
q <- asks inputQ
l <- asks chatLock
forever $
atomically (readTBQueue q) >>= \case
InputControl _ -> pure ()
@@ -139,7 +148,8 @@ inputSubscriber = do
SendGroupMessage g msg -> showSentGroupMessage g msg
_ -> printToView [plain s]
user <- asks currentUser
void . runExceptT $ processChatCommand user cmd `catchError` showChatError
withLock l . void . runExceptT $
processChatCommand user cmd `catchError` showChatError
processChatCommand :: ChatMonad m => User -> ChatCommand -> m ()
processChatCommand user@User {userId, profile} = \case
@@ -244,12 +254,14 @@ processChatCommand user@User {userId, profile} = \case
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
q <- asks $ subQ . smpAgent
l <- asks chatLock
subscribeUserConnections
forever $ do
(_, connId, msg) <- atomically $ readTBQueue q
user <- asks currentUser
-- TODO handle errors properly
void . runExceptT $ processAgentMessage user connId msg `catchError` (liftIO . print)
withLock l . void . runExceptT $
processAgentMessage user connId msg `catchError` (liftIO . print)
subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
subscribeUserConnections = void . runExceptT $ do

3
src/Simplex/Chat/Controller.hs
View File

@@ -28,7 +28,8 @@ data ChatController = ChatController
idsDrg :: TVar ChaChaDRG,
inputQ :: TBQueue InputEvent,
notifyQ :: TBQueue Notification,
sendNotification :: Notification -> IO ()
sendNotification :: Notification -> IO (),
chatLock :: TMVar ()
}
data InputEvent = InputCommand String | InputControl Char

2
stack.yaml
View File

@@ -43,7 +43,7 @@ extra-deps:
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: 703450d78e812a304e00fc59d09cc4316faf673d
commit: d9084522afa939b2993d4c3e94db90cf145ffadf
# this commit is in PR #164
#
# extra-deps: []

113
tests/ChatClient.hs
View File

@@ -1,32 +1,44 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module ChatClient where
import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread)
import Control.Concurrent.Async
import Control.Concurrent.STM (retry)
import Control.Exception (bracket_)
import Control.Concurrent.STM
import Control.Exception (bracket, bracket_)
import Control.Monad.Except
import Data.List (dropWhileEnd)
import Network.Socket
import Simplex.Chat
import Simplex.Chat.Controller (ChatController (..))
import Simplex.Chat.Options
import Simplex.Chat.Store
import Simplex.Chat.Types (Profile)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Transport
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import qualified System.Terminal as C
import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
import System.Terminal.Internal (VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal)
import System.Timeout (timeout)
testDBPrefix :: FilePath
testDBPrefix = "tests/tmp/test"
serverPort :: ServiceName
serverPort = "5000"
opts :: ChatOpts
opts =
ChatOpts
{ dbFile = undefined,
smpServers = ["localhost:5223"]
smpServers = ["localhost:5000"]
}
termSettings :: VirtualTerminalSettings
@@ -38,7 +50,13 @@ termSettings =
virtualInterrupt = retry
}
data TestCC = TestCC ChatController VirtualTerminal (Async ())
data TestCC = TestCC
{ chatController :: ChatController,
virtualTerminal :: VirtualTerminal,
chatAsync :: Async (),
termAsync :: Async (),
termQ :: TQueue String
}
aCfg :: AgentConfig
aCfg = agentConfig defaultChatConfig
@@ -56,8 +74,33 @@ virtualSimplexChat dbFile profile = do
void . runExceptT $ createUser st profile True
t <- withVirtualTerminal termSettings pure
cc <- newChatController cfg opts {dbFile} t . const $ pure () -- no notifications
a <- async $ runSimplexChat cc
pure (TestCC cc t a)
chatAsync <- async $ runSimplexChat cc
termQ <- newTQueueIO
termAsync <- async $ readTerminalOutput t termQ
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ}
readTerminalOutput :: VirtualTerminal -> TQueue String -> IO ()
readTerminalOutput t termQ = do
let w = virtualWindow t
winVar <- atomically $ newTVar . init =<< readTVar w
forever . atomically $ do
win <- readTVar winVar
win' <- init <$> readTVar w
if win' == win
then retry
else do
let diff = getDiff win' win
forM_ diff $ writeTQueue termQ
writeTVar winVar win'
where
getDiff :: [String] -> [String] -> [String]
getDiff win win' = getDiff_ 1 (length win) win win'
getDiff_ :: Int -> Int -> [String] -> [String] -> [String]
getDiff_ n len win' win =
let diff = drop (len - n) win'
in if drop n win <> diff == win'
then map (dropWhileEnd (== ' ')) diff
else getDiff_ (n + 1) len win' win
testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO ()
testChatN ps test =
@@ -95,3 +138,59 @@ testChat4 p1 p2 p3 p4 test = testChatN [p1, p2, p3, p4] test_
concurrentlyN_ :: [IO a] -> IO ()
concurrentlyN_ = mapConcurrently_ id
serverCfg :: ServerConfig
serverCfg =
ServerConfig
{ transports = [(serverPort, transport @TCP)],
tbqSize = 1,
queueIdBytes = 12,
msgIdBytes = 6,
storeLog = Nothing,
serverPrivateKey =
-- full RSA private key (only for tests)
"MIIFIwIBAAKCAQEArZyrri/NAwt5buvYjwu+B/MQeJUszDBpRgVqNddlI9kNwDXu\
\kaJ8chEhrtaUgXeSWGooWwqjXEUQE6RVbCC6QVo9VEBSP4xFwVVd9Fj7OsgfcXXh\
\AqWxfctDcBZQ5jTUiJpdBc+Vz2ZkumVNl0W+j9kWm9nfkMLQj8c0cVSDxz4OKpZb\
\qFuj0uzHkis7e7wsrKSKWLPg3M5ZXPZM1m9qn7SfJzDRDfJifamxWI7uz9XK2+Dp\
\NkUQlGQgFJEv1cKN88JAwIqZ1s+TAQMQiB+4QZ2aNfSqGEzRJN7FMCKRK7pM0A9A\
\PCnijyuImvKFxTdk8Bx1q+XNJzsY6fBrLWJZ+QKBgQCySG4tzlcEm+tOVWRcwrWh\
\6zsczGZp9mbf9c8itRx6dlldSYuDG1qnddL70wuAZF2AgS1JZgvcRZECoZRoWP5q\
\Kq2wvpTIYjFPpC39lxgUoA/DXKVKZZdan+gwaVPAPT54my1CS32VrOiAY4gVJ3LJ\
\Mn1/FqZXUFQA326pau3loQKCAQEAoljmJMp88EZoy3HlHUbOjl5UEhzzVsU1TnQi\
\QmPm+aWRe2qelhjW4aTvSVE5mAUJsN6UWTeMf4uvM69Z9I5pfw2pEm8x4+GxRibY\
\iiwF2QNaLxxmzEHm1zQQPTgb39o8mgklhzFPill0JsnL3f6IkVwjFJofWSmpqEGs\
\dFSMRSXUTVXh1p/o7QZrhpwO/475iWKVS7o48N/0Xp513re3aXw+DRNuVnFEaBIe\
\TLvWM9Czn16ndAu1HYiTBuMvtRbAWnGZxU8ewzF4wlWK5tdIL5PTJDd1VhZJAKtB\
\npDvJpwxzKmjAhcTmjx0ckMIWtdVaOVm/2gWCXDty2FEdg7koQKBgQDOUUguJ/i7\
\q0jldWYRnVkotKnpInPdcEaodrehfOqYEHnvro9xlS6OeAS4Vz5AdH45zQ/4J3bV\
\2cH66tNr18ebM9nL//t5G69i89R9W7szyUxCI3LmAIdi3oSEbmz5GQBaw4l6h9Wi\
\n4FmFQaAXZrjQfO2qJcAHvWRsMp2pmqAGwKBgQDXaza0DRsKWywWznsHcmHa0cx8\
\I4jxqGaQmLO7wBJRP1NSFrywy1QfYrVX9CTLBK4V3F0PCgZ01Qv94751CzN43TgF\
\ebd/O9r5NjNTnOXzdWqETbCffLGd6kLgCMwPQWpM9ySVjXHWCGZsRAnF2F6M1O32\
\43StIifvwJQFqSM3ewKBgCaW6y7sRY90Ua7283RErezd9EyT22BWlDlACrPu3FNC\
\LtBf1j43uxBWBQrMLsHe2GtTV0xt9m0MfwZsm2gSsXcm4Xi4DJgfN+Z7rIlyy9UY\
\PCDSdZiU1qSr+NrffDrXlfiAM1cUmCdUX7eKjp/ltkUHNaOGfSn5Pdr3MkAiD/Hf\
\AoGBAKIdKCuOwuYlwjS9J+IRGuSSM4o+OxQdwGmcJDTCpyWb5dEk68e7xKIna3zf\
\jc+H+QdMXv1nkRK9bZgYheXczsXaNZUSTwpxaEldzVD3hNvsXSgJRy9fqHwA4PBq\
\vqiBHoO3RNbqg+2rmTMfDuXreME3S955ZiPZm4Z+T8Hj52mPAoGAQm5QH/gLFtY5\
\+znqU/0G8V6BKISCQMxbbmTQVcTgGySrP2gVd+e4MWvUttaZykhWqs8rpr7mgpIY\
\hul7Swx0SHFN3WpXu8uj+B6MLpRcCbDHO65qU4kQLs+IaXXsuuTjMvJ5LwjkZVrQ\
\TmKzSAw7iVWwEUZR/PeiEKazqrpp9VU="
}
withSmpServer :: IO a -> IO a
withSmpServer = serverBracket (`runSMPServerBlocking` serverCfg) (pure ()) . const
serverBracket :: (TMVar Bool -> IO ()) -> IO () -> (ThreadId -> IO a) -> IO a
serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
bracket
(forkIOWithUnmask ($ process started))
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t)
where
waitFor started s =
5000000 `timeout` atomically (takeTMVar started) >>= \case
Nothing -> error $ "server did not " <> s
_ -> pure ()

198
tests/ChatTests.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
@@ -8,11 +9,9 @@ import ChatClient
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Data.Char (isDigit)
import Data.List (dropWhileEnd, intercalate, isPrefixOf)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Types (Profile (..), User (..))
import System.Terminal.Internal (VirtualTerminal (..))
import System.Timeout (timeout)
import Test.Hspec
@@ -43,7 +42,7 @@ testAddContact =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/c"
Just inv <- invitation <$> getWindow alice
inv <- getInvitation alice
bob ##> ("/c " <> inv)
concurrently_
(bob <## "alice (Alice): contact is connected")
@@ -54,7 +53,7 @@ testAddContact =
alice <# "bob> hi"
-- test adding the same contact one more time - local name will be different
alice ##> "/c"
Just inv' <- invitation <$> getWindow alice
inv' <- getInvitation alice
bob ##> ("/c " <> inv')
concurrently_
(bob <## "alice_1 (Alice): contact is connected")
@@ -66,7 +65,7 @@ testAddContact =
-- test deleting contact
alice ##> "/d bob_1"
alice <## "bob_1: contact is deleted"
alice #:> "@bob_1 hey"
alice #> "@bob_1 hey"
alice <## "no contact bob_1"
testGroup :: IO ()
@@ -75,21 +74,27 @@ testGroup =
\alice bob cath -> do
connectUsers alice bob
connectUsers alice cath
alice #:> "/g team"
-- TODO this occasionally fails in case getWindow is run before the command above is printed
alice <## "group #team is created\nuse /a team <name> to add members"
alice ##> "/g team"
alice <## "group #team is created"
alice <## "use /a team <name> to add members"
alice ##> "/a team bob"
concurrently_
(alice <## "invitation to join the group #team sent to bob")
(bob <## "#team: alice invites you to join the group as admin\nuse /j team to accept")
concurrentlyN_
[ alice <## "invitation to join the group #team sent to bob",
do
bob <## "#team: alice invites you to join the group as admin"
bob <## "use /j team to accept"
]
bob ##> "/j team"
concurrently_
(alice <## "#team: bob joined the group")
(bob <## "#team: you joined the group")
alice ##> "/a team cath"
concurrently_
(alice <## "invitation to join the group #team sent to cath")
(cath <## "#team: alice invites you to join the group as admin\nuse /j team to accept")
concurrentlyN_
[ alice <## "invitation to join the group #team sent to cath",
do
cath <## "#team: alice invites you to join the group as admin"
cath <## "use /j team to accept"
]
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
@@ -118,7 +123,9 @@ testGroup =
concurrentlyN_
[ bob <## "#team: you removed cath from the group",
alice <## "#team: bob removed cath from the group",
cath <## "#team: bob removed you from the group\nuse /d #team to delete the group"
do
cath <## "#team: bob removed you from the group"
cath <## "use /d #team to delete the group"
]
bob #> "#team hi"
concurrently_
@@ -128,7 +135,7 @@ testGroup =
concurrently_
(bob <# "#team alice> hello")
(cath </)
cath #:> "#team hello"
cath #> "#team hello"
cath <## "you are no longer the member of the group"
bob <##> cath
@@ -140,17 +147,23 @@ testGroup2 =
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 <## "group #club is created\nuse /a club <name> to add members"
alice ##> "/g club"
alice <## "group #club is created"
alice <## "use /a club <name> to add members"
alice ##> "/a club bob"
concurrently_
(alice <## "invitation to join the group #club sent to bob")
(bob <## "#club: alice invites you to join the group as admin\nuse /j club to accept")
concurrentlyN_
[ alice <## "invitation to join the group #club sent to bob",
do
bob <## "#club: alice invites you to join the group as admin"
bob <## "use /j club to accept"
]
alice ##> "/a club cath"
concurrently_
(alice <## "invitation to join the group #club sent to cath")
(cath <## "#club: alice invites you to join the group as admin\nuse /j club to accept")
concurrentlyN_
[ alice <## "invitation to join the group #club sent to cath",
do
cath <## "#club: alice invites you to join the group as admin"
cath <## "use /j club to accept"
]
bob ##> "/j club"
concurrently_
(alice <## "#club: bob joined the group")
@@ -166,20 +179,28 @@ testGroup2 =
bob <## "#club: new member cath is connected"
]
bob ##> "/a club dan"
concurrently_
(bob <## "invitation to join the group #club sent to dan")
(dan <## "#club: bob invites you to join the group as admin\nuse /j club to accept")
concurrentlyN_
[ bob <## "invitation to join the group #club sent to dan",
do
dan <## "#club: bob invites you to join the group as admin"
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"]
dan <## "contact alice_1 is merged into alice\nuse @alice <message> to send messages",
dan
<### [ "#club: member alice_1 (Alice) is connected",
"contact alice_1 is merged into alice",
"use @alice <message> to send messages",
"#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"
alice <## "contact dan_1 is merged into dan\nuse @dan <message> to send messages",
alice <## "contact dan_1 is merged into dan"
alice <## "use @dan <message> to send messages",
do
cath <## "#club: bob added dan (Daniel) to the group (connecting...)"
cath <## "#club: new member dan is connected"
@@ -217,7 +238,9 @@ testGroup2 =
[ cath <## "#club: you removed dan from the group",
alice <## "#club: cath removed dan from the group",
bob <## "#club: cath removed dan from the group",
dan <## "#club: cath removed you from the group\nuse /d #club to delete the group"
do
dan <## "#club: cath removed you from the group"
dan <## "use /d #club to delete the group"
]
alice #> "#club hello"
concurrentlyN_
@@ -237,14 +260,16 @@ testGroup2 =
bob <# "#club cath> hey",
(dan </)
]
dan #:> "#club how is it going?"
dan #> "#club how is it going?"
dan <## "you are no longer the member of the group"
dan <##> cath
dan <##> alice
-- member leaves
bob ##> "/l club"
concurrentlyN_
[ bob <## "#club: you left the group\nuse /d #club to delete the group",
[ do
bob <## "#club: you left the group"
bob <## "use /d #club to delete the group",
alice <## "#club: bob left the group",
cath <## "#club: bob left the group"
]
@@ -256,7 +281,7 @@ testGroup2 =
concurrently_
(alice <# "#club cath> hey")
(bob </)
bob #:> "#club how is it going?"
bob #> "#club how is it going?"
bob <## "you are no longer the member of the group"
bob <##> cath
bob <##> alice
@@ -269,12 +294,16 @@ testGroupDelete =
alice ##> "/d #team"
concurrentlyN_
[ alice <## "#team: you deleted the group",
bob <## "#team: alice deleted the group\nuse /d #team to delete the local copy of the group",
cath <## "#team: alice deleted the group\nuse /d #team to delete the local copy of the group"
do
bob <## "#team: alice deleted the group"
bob <## "use /d #team to delete the local copy of the group",
do
cath <## "#team: alice deleted the group"
cath <## "use /d #team to delete the local copy of the group"
]
bob #:> "/d #team"
bob ##> "/d #team"
bob <## "#team: you deleted the group"
cath #:> "#team hi"
cath #> "#team hi"
cath <## "you are no longer the member of the group"
testGroupRemoveAdd :: IO ()
@@ -286,22 +315,28 @@ testGroupRemoveAdd =
alice ##> "/rm team bob"
concurrentlyN_
[ alice <## "#team: you removed bob from the group",
bob <## "#team: alice removed you from the group\nuse /d #team to delete the group",
do
bob <## "#team: alice removed you from the group"
bob <## "use /d #team to delete the group",
cath <## "#team: alice removed bob from the group"
]
alice ##> "/a team bob"
bob <## "#team_1 (team): alice invites you to join the group as admin\nuse /j team_1 to accept"
alice <## "invitation to join the group #team sent to bob"
bob <## "#team_1 (team): alice invites you to join the group as admin"
bob <## "use /j team_1 to accept"
bob ##> "/j team_1"
concurrentlyN_
[ alice <## "#team: bob joined the group",
do
bob <## "#team_1: you joined the group"
bob <## "#team_1: member cath_1 (Catherine) is connected"
bob <## "contact cath_1 is merged into cath\nuse @cath <message> to send messages",
bob <## "contact cath_1 is merged into cath"
bob <## "use @cath <message> to send messages",
do
cath <## "#team: alice added bob_1 (Bob) to the group (connecting...)"
cath <## "#team: new member bob_1 is connected"
cath <## "contact bob_1 is merged into bob\nuse @bob <message> to send messages"
cath <## "contact bob_1 is merged into bob"
cath <## "use @bob <message> to send messages"
]
alice #> "#team hi"
concurrently_
@@ -319,34 +354,29 @@ testGroupRemoveAdd =
connectUsers :: TestCC -> TestCC -> IO ()
connectUsers cc1 cc2 = do
cc1 ##> "/c"
Just inv <- invitation <$> getWindow cc1
inv <- getInvitation cc1
cc2 ##> ("/c " <> inv)
concurrently_
(cc2 <## (showName cc1 <> ": contact is connected"))
(cc1 <## (showName cc2 <> ": contact is connected"))
showName :: TestCC -> String
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _) =
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _ _ _) =
T.unpack $ localDisplayName <> " (" <> fullName <> ")"
createGroup3 :: String -> TestCC -> TestCC -> TestCC -> IO ()
createGroup3 gName cc1 cc2 cc3 = do
connectUsers cc1 cc2
connectUsers cc1 cc3
cc1 #:> ("/g " <> gName)
cc1 ##> ("/g " <> gName)
cc1 <## ("group #" <> gName <> " is created")
cc1 <## ("use /a " <> gName <> " <name> to add members")
cc1 ##> ("/a team " <> name cc2)
concurrently_
(cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name cc2))
(cc2 <## ("use /j " <> gName <> " to accept"))
addMember cc2
cc2 ##> ("/j " <> gName)
concurrently_
(cc1 <## ("#" <> gName <> ": " <> name cc2 <> " joined the group"))
(cc2 <## ("#" <> gName <> ": you joined the group"))
cc1 ##> ("/a team " <> name cc3)
concurrently_
(cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name cc3))
(cc3 <## ("use /j " <> gName <> " to accept"))
addMember cc3
cc3 ##> ("/j " <> gName)
concurrentlyN_
[ cc1 <## ("#" <> gName <> ": " <> name cc3 <> " joined the group"),
@@ -358,8 +388,17 @@ createGroup3 gName cc1 cc2 cc3 = do
cc2 <## ("#" <> gName <> ": new member " <> name cc3 <> " is connected")
]
where
addMember :: TestCC -> IO ()
addMember mem = do
cc1 ##> ("/a " <> gName <> " " <> name mem)
concurrentlyN_
[ cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name mem),
do
mem <## ("#" <> gName <> ": " <> name cc1 <> " invites you to join the group as admin")
mem <## ("use /j " <> gName <> " to accept")
]
name :: TestCC -> String
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _) =
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _ _ _) =
T.unpack localDisplayName
-- | test sending direct messages
@@ -370,41 +409,37 @@ cc1 <##> cc2 = do
cc2 #> ("@" <> name cc1 <> " hey")
cc1 <# (name cc2 <> "> hey")
where
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _) = T.unpack localDisplayName
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _ _ _) = T.unpack localDisplayName
(##>) :: TestCC -> String -> IO ()
cc ##> cmd = do
cc #:> cmd
cc `send` cmd
cc <## cmd
(#>) :: TestCC -> String -> IO ()
cc #> cmd = do
cc #:> cmd
cc `send` cmd
cc <# cmd
(#:>) :: TestCC -> String -> IO ()
(TestCC cc _ _) #:> cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
send :: TestCC -> String -> IO ()
send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
(<##) :: TestCC -> String -> Expectation
cc <## line =
let n = length $ lines line
in (lastOutput n <$> getWindow cc) `shouldReturn` line
cc <## line = getTermLine cc `shouldReturn` line
(<###) :: TestCC -> [String] -> Expectation
_ <### [] = pure ()
cc <### ls = do
line <- lastOutput 1 <$> getWindow cc
line <- getTermLine cc
if line `elem` ls
then cc <### filter (/= line) ls
else error $ "unexpected output: " <> line
(<#) :: TestCC -> String -> Expectation
cc <# line =
let n = length $ lines line
in (dropTime . lastOutput n <$> getWindow cc) `shouldReturn` line
cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line
(</) :: TestCC -> Expectation
(</) cc = timeout 500000 (getWindow cc) `shouldReturn` Nothing
(</) cc = timeout 500000 (getTermLine cc) `shouldReturn` Nothing
dropTime :: String -> String
dropTime msg = case splitAt 6 msg of
@@ -412,21 +447,14 @@ dropTime msg = case splitAt 6 msg of
if all isDigit [m, m', s, s'] then text else error "invalid time"
_ -> error "invalid time"
getWindow :: TestCC -> IO [String]
getWindow (TestCC _ t _) = do
let w = virtualWindow t
win <- readTVarIO w
-- TODO to debug - putStrLn (lastOutput 1 win') - before returning it
atomically $ do
win' <- readTVar w
if win' /= win then pure win' else retry
getTermLine :: TestCC -> IO String
getTermLine = atomically . readTQueue . termQ
invitation :: [String] -> Maybe String
invitation win = lastMaybe $ map (dropWhileEnd (== ' ')) $ filter ("smp::" `isPrefixOf`) win
lastOutput :: Int -> [String] -> String
lastOutput n win = intercalate "\n" $ map (dropWhileEnd (== ' ')) $ take n $ drop (length win - n - 1) win -- - 1 to exclude prompt
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe xs = Just $ last xs
getInvitation :: TestCC -> IO String
getInvitation cc = do
cc <## "pass this invitation to your contact (via another channel):"
cc <## ""
inv <- getTermLine cc
cc <## ""
cc <## "and ask them to connect: /c <invitation_above>"
pure inv

10
tests/Test.hs
View File

@@ -1,11 +1,11 @@
import ChatClient
import ChatTests
import MarkdownTests
import ProtocolTests
import Test.Hspec
main :: IO ()
main = do
hspec $ do
describe "SimpleX chat markdown" markdownTests
describe "SimpleX chat protocol" protocolTests
xdescribe "SimpleX chat client" chatTests
main = withSmpServer . hspec $ do
describe "SimpleX chat markdown" markdownTests
describe "SimpleX chat protocol" protocolTests
describe "SimpleX chat client" chatTests