IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: stabilize tests (#2500)

Browse Source
This commit is contained in:
spaced4ndy
2023-05-24 16:14:41 +04:00
committed by GitHub
parent 24c09f2041
commit fd2c7c888c
16 changed files with 787 additions and 714 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
tests/ChatClient.hs
View File

@@ -95,7 +95,8 @@ data TestCC = TestCC
virtualTerminal :: VirtualTerminal,
chatAsync :: Async (),
termAsync :: Async (),
termQ :: TQueue String
termQ :: TQueue String,
printOutput :: Bool
}
aCfg :: AgentConfig
@@ -149,7 +150,7 @@ startTestChat_ db cfg opts user = do
atomically . unless (maintenance opts) $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
termQ <- newTQueueIO
termAsync <- async $ readTerminalOutput t termQ
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ}
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ, printOutput = False}
stopTestChat :: TestCC -> IO ()
stopTestChat TestCC {chatController = cc, chatAsync, termAsync} = do
@@ -192,6 +193,9 @@ withTestChatOpts tmp = withTestChatCfgOpts tmp testCfg
withTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatCfgOpts tmp cfg opts dbPrefix = bracket (startTestChat tmp cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
withTestOutput :: HasCallStack => TestCC -> (HasCallStack => TestCC -> IO a) -> IO a
withTestOutput cc runTest = runTest cc {printOutput = True}
readTerminalOutput :: VirtualTerminal -> TQueue String -> IO ()
readTerminalOutput t termQ = do
let w = virtualWindow t
@@ -239,14 +243,15 @@ getTermLine :: HasCallStack => TestCC -> IO String
getTermLine cc =
5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case
Just s -> do
-- uncomment 2 lines below to echo virtual terminal
-- name <- userName cc
-- putStrLn $ name <> ": " <> s
-- remove condition to always echo virtual terminal
when (printOutput cc) $ do
name <- userName cc
putStrLn $ name <> ": " <> s
pure s
_ -> error "no output for 5 seconds"
userName :: TestCC -> IO [Char]
userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser
userName (TestCC ChatController {currentUser} _ _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser
testChat2 :: HasCallStack => Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
testChat2 = testChatCfgOpts2 testCfg testOpts