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

@@ -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)

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 ()

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 <// 100000 >> stopTestChat ps cc)
+withTestChatCfgOpts ps cfg opts dbPrefix runTest =
+  bracket (startTestChat ps cfg opts dbPrefix) (stopTestChat ps) (\cc -> runTest cc >>= ((cc <// 100000) $>))
 
 -- 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_ (<// 100000) tcs
   where
     useClientServices = False
     -- useClientServices = True
     getTestCCs :: [(Profile, Int)] -> IO [TestCC]
     getTestCCs [] = pure []
     getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) useClientServices p <*> getTestCCs envs'
-    endTests tcs = do
-      mapConcurrently_ (<// 100000) tcs
-      mapConcurrently_ (stopTestChat params) tcs
 
 (<//) :: HasCallStack => TestCC -> Int -> Expectation
 (<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing
@@ -474,7 +472,7 @@ getTermLine' expected cc@TestCC {printOutput} =
       error $ name <> ": 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 ()

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"

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"

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"

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