From d23417596eaf6822396fabf992fd013fc024cce1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 5 Aug 2021 20:51:48 +0100 Subject: [PATCH] TMVar lock to avoid subscriber and client processing in parallel, fix the test (#90) * 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 --- package.yaml | 1 + src/Simplex/Chat.hs | 18 ++- src/Simplex/Chat/Controller.hs | 3 +- stack.yaml | 2 +- tests/ChatClient.hs | 113 +++++++++++++++++-- tests/ChatTests.hs | 198 +++++++++++++++++++-------------- tests/Test.hs | 10 +- 7 files changed, 243 insertions(+), 102 deletions(-) diff --git a/package.yaml b/package.yaml index 90dbff3df3..bfb1af7e4f 100644 --- a/package.yaml +++ b/package.yaml @@ -58,6 +58,7 @@ tests: - simplex-chat - async == 2.2.* - hspec == 2.7.* + - network == 3.1.* - stm == 2.5.* ghc-options: diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index bd7ed16735..21da972221 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d07331ed6c..395f62d963 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index 93b83465d7..bb21b4f3d7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index e009ef8f4b..22fd21be2d 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 () diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 22ca888e53..f144dca213 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 to add members" + alice ##> "/g team" + alice <## "group #team is created" + alice <## "use /a team 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 "#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 to add members" + alice ##> "/g club" + alice <## "group #club is created" + alice <## "use /a club 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 to send messages", + dan + <### [ "#club: member alice_1 (Alice) is connected", + "contact alice_1 is merged into alice", + "use @alice 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 to send messages", + alice <## "contact dan_1 is merged into dan" + alice <## "use @dan 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 "#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 "#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 to send messages", + bob <## "contact cath_1 is merged into cath" + bob <## "use @cath 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 to send messages" + cath <## "contact bob_1 is merged into bob" + cath <## "use @bob 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 <> " 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 ( Expectation -( 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 " + pure inv diff --git a/tests/Test.hs b/tests/Test.hs index ef5368a7ee..961475ab38 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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