From 64014cd8b085ba6c9eccce94e43dc81d68b17b07 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 24 Sep 2026 12:30:31 +0100 Subject: [PATCH] tests: stabilize (#7576) * tests: stabilize * query plans * fix test --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- src/Simplex/Chat/Core.hs | 3 +- src/Simplex/Chat/Terminal/Input.hs | 2 +- tests/ChatClient.hs | 84 +++++++++++++++--------------- tests/ChatTests/Direct.hs | 19 ++++--- tests/ChatTests/Groups.hs | 4 +- tests/ChatTests/Profiles.hs | 4 +- tests/ChatTests/Utils.hs | 2 +- 7 files changed, 63 insertions(+), 55 deletions(-) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index f5f7f581df..433e2605fd 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -42,6 +42,7 @@ import System.Exit (exitFailure) import System.IO (hFlush, stdout) import Text.Read (readMaybe) import UnliftIO.Async +import UnliftIO.Exception (finally) simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO () simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {dbOptions, logAgent, yesToUpMigrations, migrationBackupPath, maintenance}, createBot, userDisplayName, userImageFile} chat = @@ -89,7 +90,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@Cha runSimplexChat :: ChatConfig -> ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO () runSimplexChat ChatConfig {testView} ChatOpts {coreOptions = CoreChatOpts {chatRelay, chatRelayServer, headless, maintenance}} u cc@ChatController {config = ChatConfig {chatHooks}} chat | maintenance = wait =<< async (chat u cc) - | otherwise = do + | otherwise = flip finally (stopChatController cc) $ do a1 <- runReaderT (startChatController True True False) cc when (chatRelay && not testView) $ askCreateRelayAddress cc u chatRelayServer headless forM_ (postStartHook chatHooks) ($ cc) diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index fa5efd0354..3f1c434433 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -154,7 +154,7 @@ sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do runTerminalInput :: ChatTerminal -> ChatController -> IO () runTerminalInput ct cc = withChatTerm ct $ do - updateInput ct + withTermLock ct $ updateInput ct receiveFromTTY cc ct receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m () diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 0a7914d366..d321e37b72 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -40,7 +40,7 @@ import Simplex.Chat.Options.DB import Simplex.Chat.Store import Simplex.Chat.Store.Profiles import Simplex.Chat.Terminal -import Simplex.Chat.Terminal.Output (newChatTerminal) +import Simplex.Chat.Terminal.Output (WithTerminal (..), newChatTerminal) import Simplex.Chat.Types import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.FileTransfer.Description (kb, mb) @@ -70,7 +70,7 @@ import Simplex.Messaging.Version.Internal import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.FilePath (()) import qualified System.Terminal as C -import System.Terminal.Internal (VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal) +import System.Terminal.Internal (Command (..), Terminal (..), VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal) import System.Timeout (timeout) import Test.Hspec (Expectation, HasCallStack, shouldReturn) #if defined(dbPostgres) @@ -197,13 +197,32 @@ termSettings = data TestCC = TestCC { chatController :: ChatController, - virtualTerminal :: VirtualTerminal, chatAsync :: Async (), - termAsync :: Async (), termQ :: TQueue String, printOutput :: Bool } +data TestTerminal = TestTerminal VirtualTerminal (TQueue String) + +instance Terminal TestTerminal where + termType (TestTerminal t _) = termType t + termEvent (TestTerminal t _) = termEvent t + termInterrupt (TestTerminal t _) = termInterrupt t + termCommand (TestTerminal t q) c = do + case c of + PutLn -> atomically $ do + C.Position {row} <- readTVar $ virtualCursor t + rows <- readTVar $ virtualWindow t + writeTQueue q $ dropWhileEnd (== ' ') $ rows !! row + _ -> pure () + termCommand t c + termFlush (TestTerminal t _) = termFlush t + termGetWindowSize (TestTerminal t _) = termGetWindowSize t + termGetCursorPosition (TestTerminal t _) = termGetCursorPosition t + +instance WithTerminal TestTerminal where + withTerm t = ($ t) + aCfg :: AgentConfig aCfg = (agentConfig defaultChatConfig) {tbqSize = 16} @@ -306,29 +325,31 @@ insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) V startTestChat_ :: TestParams -> ChatDatabase -> ChatConfig -> ChatOpts -> String -> User -> IO TestCC startTestChat_ TestParams {tmpPath, printOutput} db cfg opts@ChatOpts {coreOptions = CoreChatOpts {maintenance}} dbPrefix user = do - t <- withVirtualTerminal termSettings pure + termQ <- newTQueueIO + t <- withVirtualTerminal termSettings $ pure . (`TestTerminal` termQ) ct <- newChatTerminal t opts Right cc <- newChatController db (Just user) cfg opts False void $ execChatCommand' (SetTempFolder (tmpPath dbPrefix)) 0 `runReaderT` cc chatAsync <- async $ runSimplexChat cfg opts user cc $ \_u cc' -> runChatTerminal ct cc' opts unless maintenance $ atomically $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry - termQ <- newTQueueIO - termAsync <- async $ readTerminalOutput t termQ - pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ, printOutput} + pure TestCC {chatController = cc, chatAsync, termQ, printOutput} stopTestChat :: TestParams -> TestCC -> IO () -stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}, chatAsync, termAsync} = do - stopChatController cc - uninterruptibleCancel termAsync - uninterruptibleCancel chatAsync - liftIO $ disposeAgentClient smpAgent +stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}, chatAsync} = do + stopped <- async $ do + stopChatController cc + cancel chatAsync + disposeAgentClient smpAgent + r <- timeout 60000000 $ wait stopped #if !defined(dbPostgres) chatStats <- withConnection chatStore $ readTVarIO . DB.slow atomically $ modifyTVar' (chatQueryStats ps) $ M.unionWith combineStats chatStats agentStats <- withConnection (agentClientStore smpAgent) $ readTVarIO . DB.slow atomically $ modifyTVar' (agentQueryStats ps) $ M.unionWith combineStats agentStats #endif - closeDBStore chatStore + case r of + Just () -> closeDBStore chatStore + Nothing -> putStrLn "stopTestChat: chat did not stop in 60 seconds" threadDelay 200000 #if !defined(dbPostgres) where @@ -381,7 +402,8 @@ withTestChatOpts :: HasCallStack => TestParams -> ChatOpts -> String -> (HasCall withTestChatOpts ps = withTestChatCfgOpts ps testCfg withTestChatCfgOpts :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a -withTestChatCfgOpts ps cfg opts dbPrefix = bracket (startTestChat ps cfg opts dbPrefix) (\cc -> cc > stopTestChat ps cc) +withTestChatCfgOpts ps cfg opts dbPrefix runTest = + bracket (startTestChat ps cfg opts dbPrefix) (stopTestChat ps) (\cc -> runTest cc >>= ((cc )) -- enable output for specific test. -- usage: withTestOutput $ testChat2 aliceProfile bobProfile $ \alice bob -> do ... @@ -408,29 +430,6 @@ enableNamesRole TestCC {chatController = cc} = do } enableNames srv@UserServer {roles} = (srv :: UserServer 'PSMP) {roles = (roles :: ServerRolesOverride) {names = Just True}} -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 - withTmpFiles :: IO () -> IO () withTmpFiles = bracket_ @@ -439,16 +438,15 @@ withTmpFiles = testChatN :: HasCallStack => ChatConfig -> ChatOpts -> [Profile] -> (HasCallStack => [TestCC] -> IO ()) -> TestParams -> IO () testChatN cfg opts ps test params = - bracket (getTestCCs $ zip ps [1 ..]) endTests test + bracket (getTestCCs $ zip ps [1 ..]) (mapConcurrently_ $ stopTestChat params) $ \tcs -> do + test tcs + mapConcurrently_ ( IO [TestCC] getTestCCs [] = pure [] getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) useClientServices p <*> getTestCCs envs' - endTests tcs = do - mapConcurrently_ ( TestCC -> Int -> Expectation ( ": no output for 5 seconds" <> expectedMsg userName :: TestCC -> IO [Char] -userName (TestCC ChatController {currentUser} _ _ _ _ _) = +userName TestCC {chatController = ChatController {currentUser}} = maybe "no current user" (\User {localDisplayName} -> T.unpack localDisplayName) <$> readTVarIO currentUser testChat :: HasCallStack => Profile -> (HasCallStack => TestCC -> IO ()) -> TestParams -> IO () diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index b630039c62..6a85f6f463 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -21,7 +21,7 @@ import Data.Aeson (ToJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.List (intercalate, stripPrefix) +import Data.List (intercalate, isPrefixOf, stripPrefix) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) import qualified Data.Text as T @@ -1351,18 +1351,23 @@ testNegotiateCall = alice ##> "/_call status @2 connected" alice <## "ok" threadDelay 100000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: in progress (00:00)")]) + alice #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(1, "outgoing call: in progress")]) bob ##> "/_call status @2 connected" bob <## "ok" threadDelay 100000 - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: in progress (00:00)")]) + bob #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(0, "incoming call: in progress")]) -- either party can end the call bob ##> "/_call end @2" bob <## "ok" threadDelay 100000 - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: ended (00:00)")]) + bob #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(0, "incoming call: ended")]) alice <## "call with bob ended" - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: ended (00:00)")]) + alice #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(1, "outgoing call: ended")]) + where + callChat = map (fmap noDuration) . chat + noDuration s = case words s of + ws@(_ : _) | "(0" `isPrefixOf` last ws -> unwords $ init ws + _ -> s testStopStartChat :: HasCallStack => TestParams -> IO () testStopStartChat ps = @@ -3112,13 +3117,15 @@ testMsgDecryptError ps = withTestChat ps "bob" $ \bob -> do bob <## "subscribed 1 connections on server localhost" alice #> "@bob hello again" - bob <# "alice> skipped message ID 9..11" + bob <# "alice> skipped message ID 7..9" bob <# "alice> hello again" bob #> "@alice received!" alice <# "bob> received!" setupDesynchronizedRatchet :: HasCallStack => TestParams -> TestCC -> IO () setupDesynchronizedRatchet ps alice = do + alice ##> "/set receipts all off" + alice <## "ok" copyDb "bob" "bob_old" withTestChat ps "bob" $ \bob -> do bob <## "subscribed 1 connections on server localhost" diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index e2bcc5e3e6..0cc697b012 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -4149,13 +4149,15 @@ testGroupMsgDecryptError ps = withTestChat ps "bob" $ \bob -> do bob <## "subscribed 2 connections on server localhost" alice #> "#team hello again" - bob <# "#team alice> skipped message ID 8..10" + bob <# "#team alice> skipped message ID 6..8" bob <# "#team alice> hello again" bob #> "#team received!" alice <# "#team bob> received!" setupDesynchronizedRatchet :: HasCallStack => TestParams -> TestCC -> IO () setupDesynchronizedRatchet ps alice = do + alice ##> "/set receipts all off" + alice <## "ok" copyDb "bob" "bob_old" withTestChat ps "bob" $ \bob -> do bob <## "subscribed 2 connections on server localhost" diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 6fb8ad44fe..2a4eeccb74 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1672,7 +1672,7 @@ testPlanAddressContactViaAddress = bob ##> ("/c " <> cLink) connecting alice bob - bob ##> "/delete @alice" + bob ##> "/delete @alice notify=off" bob <## "alice: contact is deleted" alice ##> "/delete @bob" alice <## "bob: contact is deleted" @@ -1734,7 +1734,7 @@ testPlanAddressContactViaShortAddress = bob ##> ("/c " <> sLink) connecting alice bob - bob ##> "/delete @alice" + bob ##> "/delete @alice notify=off" bob <## "alice: contact is deleted" alice ##> "/delete @bob" alice <## "bob: contact is deleted" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 305207fef6..9586957281 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -745,7 +745,7 @@ connectUsers_ cc1 cc2 noShortLink = do (cc1 <## (name2 <> ": contact is connected")) showName :: TestCC -> IO String -showName (TestCC ChatController {currentUser} _ _ _ _ _) = do +showName TestCC {chatController = ChatController {currentUser}} = do Just User {localDisplayName, profile = LocalProfile {fullName, shortDescr}} <- readTVarIO currentUser pure . T.unpack $ viewName localDisplayName <> optionalFullName localDisplayName fullName shortDescr