core, tests: fix flaky tests; use simplexmq with one thread per agent worker (#7812)

* tests: fix group tests

* fix test

* fix

* fix delivery worker fix

* watch ci

* debug

* fix delivery worker not forwarding to moderators during host acceptance

* add script, update simplexmq

* debug lines

* more debug

* rerun

* debug

* fix, debug

* simplexmq

* simplexmq

* fix

* debug: log member-not-found call sites, restore hang diagnostics, use simplexmq fork

* tests: do not prompt for migration confirmation in strict tables test

* ci: run tests with one capability; simplexmq: end inactive sessions without closing under readers

* ci: run tests on all capabilities

* remote: close the HTTP2 client before its TLS connection

* cabal: use warp that kills timed out connection threads without closing their sockets

* remove diagnostics: member-not-found log, thread dump, CI watchdog; update simplexmq

* badge-service: prevent interleaving of concurrent log lines

* tests: wait for badge group broadcasts before closing members

* tests: log contact connected events received twice

* tests: log member connected events received twice

* core: use simplexmq that logs connections emitting CON twice

* core: keep the team contact above notes in a new user's chat list

* ci: skip macOS and Windows builds while hunting a Linux-only flake

* core: use simplexmq that logs the history of connections emitting CON twice

* tests: remove the logging of connected events received twice

* ci: run macOS and Windows builds again

* core: use simplexmq that runs one thread per agent worker

* core: use the merged simplex-chat/wai warp and the updated simplexmq

* core: use the merged simplexmq

* core: update simplexmq

* core, badge service: comment single writes of terminal segments and log lines

apps/simplex-badge-service/src/BadgeService/Log.hs

@@ -9,9 +9,10 @@ module BadgeService.Log
 where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Data.ByteString as B
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Time.LocalTime (getZonedTime)
 import GHC.Stack (CallStack, HasCallStack, callStack, getCallStack, srcLocFile, srcLocStartLine)
@@ -29,7 +30,8 @@ logError = logAt "ERROR" callStack
 logAt :: MonadIO m => Text -> CallStack -> Text -> m ()
 logAt tag cs msg = liftIO $ do
   ts <- formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %z" <$> getZonedTime
-  T.hPutStrLn stderr $ "[" <> tag <> " " <> T.pack ts <> " " <> loc <> "] " <> msg
+  -- one write per line, putStrLn family is not atomic
+  B.hPut stderr $ encodeUtf8 $ "[" <> tag <> " " <> T.pack ts <> " " <> loc <> "] " <> msg <> "\n"
   where
     loc = case getCallStack cs of
       ((_, l) : _) -> T.pack (srcLocFile l) <> ":" <> T.pack (show (srcLocStartLine l))

cabal.project

@@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: 8bc4d3601250d9f79dc7e80ead319ec2b6d4a95a
+    tag: 381828400710344bc1c6ce94e7cdf6e0ca043ee9
 
 source-repository-package
     type: git
@@ -70,5 +70,5 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/wai.git
-    tag: 2f6e5aa5f05ba9140ac99e195ee647b4f7d926b0
+    tag: 63667cb577d09c967ddcd945e42c324872dfeb7d
     subdir: warp

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."8bc4d3601250d9f79dc7e80ead319ec2b6d4a95a" = "1zzrbqqbaw6sa3midyv9qgnypsjp17h5yhgi7bffldcncyl4w1ni";
+  "https://github.com/simplex-chat/simplexmq.git"."381828400710344bc1c6ce94e7cdf6e0ca043ee9" = "0cayvxjcyhlp2ckw57c8ny72va7mcc6vifd896kmxi6l8s7pppkj";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."2330df3dc8c4b660674d3c02d76bb86f66c2abee" = "11pfj1vqsjdl26nplkr2l6z1xj7cn153qijj5gknmlzq3krn7x1i";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
@@ -8,5 +8,5 @@
   "https://github.com/simplex-chat/android-support.git"."9aa09f148089d6752ce563b14c2df1895718d806" = "0pbf2pf13v2kjzi397nr13f1h3jv0imvsq8rpiyy2qyx5vd50pqn";
   "https://github.com/simplex-chat/zip.git"."2eff156c3aac389e35d38bf10a52733d7061640a" = "052vahd5d4lxnazjrb6l60i261aycn2js7jhzafyb72n15ns4r6p";
   "https://github.com/yesodweb/wai.git"."ec5e017d896a78e787a5acea62b37a4e677dec2e" = "1ckcpmpjfy9jiqrb52q20lj7ln4hmq9v2jk6kpkf3m68c1m9c2bx";
-  "https://github.com/simplex-chat/wai.git"."2f6e5aa5f05ba9140ac99e195ee647b4f7d926b0" = "199g4rjdf1zp1fcw8nqdsyr1h36hmg424qqx03071jk7j00z7ay4";
+  "https://github.com/simplex-chat/wai.git"."63667cb577d09c967ddcd945e42c324872dfeb7d" = "1nh4j3fnxbpkdhz1sfgpfhb7j0371apbmx1kv7aqa2zrdxc8gmzb";
 }

src/Simplex/Chat/Library/Commands.hs

@@ -476,8 +476,8 @@ processChatCommand cxt nm = \case
     user <- withFastStore $ \db -> do
       user <- createUserRecordAt db (AgentUserId auId) (isTrue userChatRelay) service p True ts
       mapM_ (setUserServers db user ts) uss
-      createPresetContactCards db user `catchAllErrors` \_ -> pure ()
       createNoteFolder db user
+      createPresetContactCards db user `catchAllErrors` \_ -> pure ()
       pure user
     atomically . writeTVar u $ Just user
     pure $ CRActiveUser user

src/Simplex/Chat/Library/Subscriber.hs

@@ -25,7 +25,7 @@ import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Either (lefts, partitionEithers, rights)
+import Data.Either (isLeft, lefts, partitionEithers, rights)
 import Data.Foldable (foldr', foldrM)
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -1130,7 +1130,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
               XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe
               BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup (GIK gInfo' gks) m'' sharedMsgId chunk msgMeta
               _ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
-            forM deliveryTaskContext_ $ \taskContext -> do
+            forM (if memberStatus m'' == GSMemPendingApproval then Nothing else deliveryTaskContext_) $ \taskContext -> do
               let contentChanged :: CM ()
                   contentChanged = atomically $ channelContentChanged cc groupId
               case event of
@@ -4193,11 +4193,16 @@ resumeDeliveryTaskWork :: DeliveryWorkerKey -> CM' ()
 resumeDeliveryTaskWork = void . getDeliveryTaskWorker False
 
 getDeliveryTaskWorker :: Bool -> DeliveryWorkerKey -> CM' Worker
-getDeliveryTaskWorker hasWork deliveryKey = do
+getDeliveryTaskWorker hasWork deliveryKey@(groupId, _) = do
   ws <- asks deliveryTaskWorkers
   a <- asks smpAgent
-  getAgentWorker "delivery_task" hasWork a deliveryKey ws $
-    runDeliveryTaskWorker a deliveryKey
+  getAgentWorker "delivery_task" hasWork a deliveryKey ws $ \w ->
+    runDeliveryTaskWorker a deliveryKey w `catchAllErrors` \e -> do
+      whenM (groupDeleted groupId) $ atomically $ TM.delete deliveryKey ws
+      throwError e
+
+groupDeleted :: GroupId -> CM Bool
+groupDeleted groupId = isLeft <$> withStore' (\db -> runExceptT $ getUserByGroupId db groupId)
 
 runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
 runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
@@ -4220,7 +4225,7 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
         processDeliveryTask task
           `catchAllErrors` \e -> do
             withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) (tshow e)
-            eToView e
+            unlessM (groupDeleted groupId) $ eToView e
       where
         processDeliveryTask :: MessageDeliveryTask -> CM ()
         processDeliveryTask task@MessageDeliveryTask {jobScope} =
@@ -4261,11 +4266,13 @@ resumeDeliveryJobWork :: DeliveryWorkerKey -> CM' ()
 resumeDeliveryJobWork = void . getDeliveryJobWorker False
 
 getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> CM' Worker
-getDeliveryJobWorker hasWork deliveryKey = do
+getDeliveryJobWorker hasWork deliveryKey@(groupId, _) = do
   ws <- asks deliveryJobWorkers
   a <- asks smpAgent
-  getAgentWorker "delivery_job" hasWork a deliveryKey ws $
-    runDeliveryJobWorker a deliveryKey
+  getAgentWorker "delivery_job" hasWork a deliveryKey ws $ \w ->
+    runDeliveryJobWorker a deliveryKey w `catchAllErrors` \e -> do
+      whenM (groupDeleted groupId) $ atomically $ TM.delete deliveryKey ws
+      throwError e
 
 -- TODO [relays] dissemination here is unsigned (relay-asserted profile).
 -- Future: members sign an XMember on channel join, relay stores it per
@@ -4308,7 +4315,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
         processDeliveryJob job
           `catchAllErrors` \e -> do
             withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e)
-            eToView e
+            unlessM (groupDeleted groupId) $ eToView e
       where
         processDeliveryJob :: MessageDeliveryJob -> CM ()
         processDeliveryJob job =

src/Simplex/Chat/Remote.hs

@@ -297,9 +297,9 @@ cancelRemoteHost handlingError = \case
     closeConnection tls
   RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do
     uninterruptibleCancel pollAction
+    unless handlingError $ closeHTTP2Client httpClient `catchAny` (logError . tshow)
     cancelHostClient rchClient `catchAny` (logError . tshow)
     closeConnection tls `catchAny` (logError . tshow)
-    unless handlingError $ closeHTTP2Client httpClient `catchAny` (logError . tshow)
   where
     cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do
       unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError . tshow)

src/Simplex/Chat/Terminal/Output.hs

@@ -388,8 +388,9 @@ printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg
 -- because of accounting for control sequences in length
 putStyled :: MonadTerminal m => StyledString -> m ()
 putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
-putStyled (Styled [] s) = putString s
-putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
+-- putText, as putString sends a terminal command per character
+putStyled (Styled [] s) = putText (T.pack s)
+putStyled (Styled sgr s) = setSGR sgr >> putText (T.pack s) >> resetAttributes
 
 setSGR :: MonadTerminal m => [SGR] -> m ()
 setSGR = mapM_ $ \case

tests/Bots/BadgeService/GroupIntegrationTests.hs

@@ -171,11 +171,14 @@ runGroupServiceAs svc groupCfg action = do
   -- The web listener starts after group start-up, so the stop cannot land inside start-up's database calls.
   let started = pollUntilTrue (listening port) >> pollUntil (getStoredGroup cc)
       -- A stop inside a lane's database call leaves a statement open, and closing the store then fails.
-      settle gid = when (isJust groupCfg) $ do
-        status <- memberStatus cc gid badgeBotName
-        forM_ status $ \s -> unless (s `elem` ["removed", "left", "deleted"]) $ settleLane cc env gid
+      settle gid = when (isJust groupCfg) $ settleServingLane cc env gid
   (started >>= \ManagedGroup {mgGroupId} -> action cc env mgGroupId <* settle mgGroupId) `finally` stopGroupService t cc
 
+settleServingLane :: HasCallStack => ChatController -> ServiceState -> Int64 -> IO ()
+settleServingLane cc env gid = do
+  status <- memberStatus cc gid badgeBotName
+  forM_ status $ \s -> unless (s `elem` ["removed", "left", "deleted"]) $ settleLane cc env gid
+
 -- It returns once chat has started, while group start-up may still run; the Int is its web listener's port.
 startGroupService :: HasCallStack => GroupSvc -> Maybe GroupConfig -> IO (Async (), ChatController, ServiceState, Int)
 startGroupService svc@GroupSvc {gsCfg} groupCfg = do
@@ -228,25 +231,31 @@ withGroupOwner ps action = do
   runWithOwner svc $ \cc env _ -> action gsKey cc env
 
 runWithOwner :: HasCallStack => GroupSvc -> (ChatController -> ServiceState -> Int64 -> TestCC -> IO a) -> IO a
-runWithOwner svc@GroupSvc {gsPs} action = runGroupService svc $ \cc env gid -> withOwnerJoined gsPs cc gid $ action cc env gid
+runWithOwner svc@GroupSvc {gsPs} action = runGroupService svc $ \cc env gid -> withOwnerJoined gsPs cc env gid $ action cc env gid
 
-withOwnerJoined :: HasCallStack => TestParams -> ChatController -> Int64 -> (TestCC -> IO a) -> IO a
-withOwnerJoined ps cc gid action =
+withOwnerJoined :: HasCallStack => TestParams -> ChatController -> ServiceState -> Int64 -> (TestCC -> IO a) -> IO a
+withOwnerJoined ps cc env gid action =
   withNewTestChat ps "alice" aliceProfile $ \alice -> do
     joinGroup cc alice
     waitMemberRole cc gid "alice" "owner"
     drainUntil alice ["#" <> groupName <> ": " <> botName <> " changed your role from member to owner"]
+    joined <- lastMessageId cc
     r <- action alice
+    settleServingLane cc env gid
+    awaitBroadcasts cc joined "alice" alice
     drainConsole alice
     pure r
 
 -- Bob joins after the first member and is connected to her.
-withMemberJoined :: HasCallStack => TestParams -> ChatController -> TestCC -> (TestCC -> IO a) -> IO a
-withMemberJoined ps cc alice action =
+withMemberJoined :: HasCallStack => TestParams -> ChatController -> ServiceState -> Int64 -> TestCC -> (TestCC -> IO a) -> IO a
+withMemberJoined ps cc env gid alice action =
   withNewTestChat ps "bob" bobProfile $ \bob -> do
     joinGroup cc bob
     drainUntil alice ["#" <> groupName <> ": new member bob is connected"]
+    joined <- lastMessageId cc
     r <- action bob
+    settleServingLane cc env gid
+    awaitBroadcasts cc joined "bob" bob
     drainConsole bob
     pure r
 
@@ -315,7 +324,7 @@ testEarliestPromotedOnLaterJoin ps = do
   runWithOwner svc $ \cc env gid alice -> do
     setMemberRole cc gid "alice" "member"
     executeSql cc "UPDATE sx_badge_service_group SET owner_bootstrapped = 0"
-    withMemberJoined ps cc alice $ \_ -> do
+    withMemberJoined ps cc env gid alice $ \_ -> do
       waitMemberRole cc gid "alice" "owner"
       awaitLane cc env
       memberRoles cc gid `shouldReturn` [("alice", "owner"), ("bob", "member")]
@@ -428,7 +437,7 @@ memberStatus cc gid name =
 withTwoMembersOwnerUnset :: HasCallStack => GroupSvc -> (ChatController -> Int64 -> TestCC -> IO ()) -> IO ()
 withTwoMembersOwnerUnset svc@GroupSvc {gsPs = ps} action =
   runWithOwner svc $ \cc env gid alice ->
-    withMemberJoined ps cc alice $ \bob -> do
+    withMemberJoined ps cc env gid alice $ \bob -> do
       -- The lane must handle bob's join before the flag is cleared, or it would act on the cleared flag in this run.
       awaitLane cc env
       action cc gid bob
@@ -437,8 +446,8 @@ withTwoMembersOwnerUnset svc@GroupSvc {gsPs = ps} action =
 testFirstJoinerPromoted :: HasCallStack => TestParams -> IO ()
 testFirstJoinerPromoted ps = do
   svc <- prepareGroupService ps
-  runWithOwner svc $ \cc _ gid alice ->
-    withMemberJoined ps cc alice $ \bob -> do
+  runWithOwner svc $ \cc env gid alice ->
+    withMemberJoined ps cc env gid alice $ \bob -> do
       waitMemberRole cc gid "bob" "member"
       -- The bot queues bob's join before it introduces him, so alice's code proves the join was handled.
       sendGroupCmd alice "/issue supporter"
@@ -459,7 +468,7 @@ testFailedPromotionNotRetried ps = do
       pollUntilTrue $ mgOwnerBootstrapped <$> storedGroup cc
       awaitLane cc env
       setBotRole cc "owner"
-      withMemberJoined ps cc alice $ \_ -> awaitLane cc env
+      withMemberJoined ps cc env gid alice $ \_ -> awaitLane cc env
       memberRoles cc gid `shouldReturn` [("alice", "member"), ("bob", "member")]
       drainConsole alice
 
@@ -504,8 +513,8 @@ testRoleGatedIssue ps = do
 testBlockedMemberCommandIgnored :: HasCallStack => TestParams -> IO ()
 testBlockedMemberCommandIgnored ps = do
   svc <- prepareGroupService ps
-  runWithOwner svc $ \cc _ gid alice ->
-    withMemberJoined ps cc alice $ \bob -> do
+  runWithOwner svc $ \cc env gid alice ->
+    withMemberJoined ps cc env gid alice $ \bob -> do
       waitMemberRole cc gid "bob" "member"
       -- bob is made moderator so that only the block can refuse his command.
       send alice ("/mr #" <> groupName <> " bob moderator")
@@ -1255,6 +1264,29 @@ drainConsole cc =
     Just _ -> drainConsole cc
     Nothing -> pure ()
 
+lastMessageId :: ChatController -> IO Int64
+lastMessageId cc = fromMaybe 0 <$> queryFirst cc "SELECT COALESCE(MAX(message_id), 0) FROM messages"
+
+awaitBroadcasts :: HasCallStack => ChatController -> Int64 -> Text -> TestCC -> IO ()
+awaitBroadcasts cc joined name TestCC {chatController = memberCC} = do
+  lastBroadcast <- listToMaybe <$> queryRows cc lastBroadcastSql
+  forM_ lastBroadcast $ \(gid, sharedMsgId) -> do
+    status <- memberStatus cc gid name
+    when (maybe False (`notElem` ["removed", "left", "deleted"]) status) $
+      pollUntilTrue $ isJust <$> (queryFirst memberCC (receivedSql sharedMsgId) :: IO (Maybe Int64))
+  where
+    lastBroadcastSql =
+      "SELECT group_id, " <> hexSharedMsgId <> " FROM messages WHERE msg_sent = 1 AND message_id > " <> show joined
+        <> " AND chat_msg_event IN ('x.msg.new', 'x.msg.update', 'x.msg.del') ORDER BY message_id DESC LIMIT 1"
+    receivedSql sharedMsgId = "SELECT message_id FROM messages WHERE msg_sent = 0 AND " <> hexSharedMsgId <> " = '" <> T.unpack sharedMsgId <> "'"
+
+hexSharedMsgId :: String
+#if defined(dbPostgres)
+hexSharedMsgId = "encode(shared_msg_id, 'hex')"
+#else
+hexSharedMsgId = "hex(shared_msg_id)"
+#endif
+
 -- A console silent this long is taken as drained.
 quietPeriod :: Int
 quietPeriod = 500000

tests/Bots/BadgeService/WebTests.hs

@@ -53,7 +53,9 @@ import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime, secondsToDiffTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Word (Word32, Word8)
-import GHC.IO.Handle (hDuplicate, hDuplicateTo)
+import qualified GHC.IO.Device as IODevice
+import qualified GHC.IO.FD as FD
+import GHC.IO.Handle.FD (handleToFd)
 import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)
 import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
 import Network.HTTP.Types.Status (statusCode)
@@ -72,7 +74,7 @@ import Simplex.Messaging.Encoding.String (textDecode, textEncode)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
 import System.FilePath ((</>))
-import System.IO (IOMode (..), hClose, hGetBuffering, hSetBuffering, stderr, withFile)
+import System.IO (IOMode (..), hFlush, stderr, withFile)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Timeout (timeout)
 import Test.Hspec
@@ -2675,16 +2677,16 @@ stderrCaptureLock :: MVar ()
 stderrCaptureLock = unsafePerformIO $ newMVar ()
 {-# NOINLINE stderrCaptureLock #-}
 
--- hDuplicateTo changes stderr's buffering, so put the original setting back.
 capturingStderr :: IO () -> IO Text
 capturingStderr action = withMVar stderrCaptureLock $ \_ -> do
   createDirectoryIfMissing True "tests/tmp"
   withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do
     let path = dir </> "stderr.log"
     withFile path WriteMode $ \h -> do
-      buffering <- hGetBuffering stderr
-      saved <- hDuplicate stderr
-      (hDuplicateTo h stderr >> action) `E.finally` (hDuplicateTo saved stderr >> hClose saved >> hSetBuffering stderr buffering)
+      fd <- handleToFd h
+      hFlush stderr
+      saved <- IODevice.dup FD.stderr
+      (IODevice.dup2 fd FD.stderr >> action) `E.finally` (hFlush stderr >> IODevice.dup2 saved FD.stderr >> IODevice.close saved)
     T.readFile path
 
 loggedError :: Text -> Text -> Bool

tests/Bots/DirectoryTests.hs

@@ -14,7 +14,7 @@ import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (async, cancel)
 import Control.Concurrent.STM (atomically, peekTQueue, tryReadTMVar)
 import Control.Exception (finally)
-import Control.Monad (forM_, when, void)
+import Control.Monad (forM_, replicateM, when, void)
 import qualified Data.Aeson as J
 import qualified Data.Text as T
 import Directory.Captcha
@@ -421,12 +421,9 @@ testJoinGroup ps =
           cath <## "connection request sent!"
           cath <## "#privacy: joining the group..."
           cath <## "#privacy: you joined the group, pending approval"
-          cath <# "#privacy (support) 'SimpleX Directory_1'> Captcha is generated by SimpleX Directory service."
-          cath <## ""
-          cath <## "Send captcha text to join the group privacy."
-          captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory_1'> " . dropTime <$> getTermLine cath
-          cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'"
-          cath <## "use @'SimpleX Directory' <message> to send messages"
+          let merged = ["contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'", "use @'SimpleX Directory' <message> to send messages"]
+          [_, "", "Send captcha text to join the group privacy.", captchaLine] <- filter (`notElem` merged) <$> replicateM 6 (getTermLine cath)
+          let captcha = drop 2 $ dropWhile (/= '>') captchaLine
           cath #> ("#privacy (support) " <> captcha)
           cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha)
           cath <## "      Correct, you joined the group privacy"

tests/ChatTests/ChatRelays.hs

@@ -221,7 +221,7 @@ testChatRelayTest ps =
         bob <## "Your chat address is deleted - accepted contacts will remain connected."
         bob <## "To create a new chat address use /ad"
         alice ##> ("/relay test " <> bobSLink)
-        alice <##. "relay test failed at RTSGetLink, error: "
+        alice <##.. ["relay test failed at RTSGetLink, error: ", "relay test failed at RTSConnect, error: "]
 
 testRelayProfileUpdateInAddress :: HasCallStack => TestParams -> IO ()
 testRelayProfileUpdateInAddress ps =

tests/ChatTests/Groups.hs

@@ -28,7 +28,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Maybe (fromMaybe, isJust, maybeToList)
 import Data.Time (UTCTime, getCurrentTime)
 import Data.Int (Int64)
-import Data.List (intercalate, isInfixOf, isSuffixOf)
+import Data.List (intercalate, isInfixOf, isSubsequenceOf, isSuffixOf)
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Simplex.Chat.Badges (FileSizeLimits (..))
@@ -6282,7 +6282,7 @@ testGroupHistory =
 
       cath ##> "/_get chat #1 count=100"
       r <- chat <$> getTermLine cath
-      r `shouldContain` [(0, "hello"), (0, "hey!")]
+      r `shouldSatisfy` isSubsequenceOf [(0, "hello"), (0, "hey!")]
 
       -- message delivery works after sending history
       alice #> "#team 1"
@@ -6376,7 +6376,7 @@ testGroupHistoryPreferenceOff =
 
       cath ##> "/_get chat #1 count=100"
       r <- chat <$> getTermLine cath
-      r `shouldContain` [(0, "hello"), (0, "hey!")]
+      r `shouldSatisfy` isSubsequenceOf [(0, "hello"), (0, "hey!")]
 
       alice ##> "/set history #team off"
       alice <## "updated group preferences:"
@@ -6642,9 +6642,10 @@ testGroupHistoryMultipleFiles =
       cath ##> "/_get chat #1 count=100"
       r <- chatF <$> getTermLine cath
       r
-        `shouldContain` [ ((0, "hi alice"), Just $ tmpFile cath "testfile_bob_1"),
-                          ((0, "hey bob"), Just $ tmpFile cath "testfile_alice_1")
-                        ]
+        `shouldSatisfy` isSubsequenceOf
+          [ ((0, "hi alice"), Just $ tmpFile cath "testfile_bob_1"),
+            ((0, "hey bob"), Just $ tmpFile cath "testfile_alice_1")
+          ]
 
 testGroupHistoryFileCancel :: HasCallStack => TestParams -> IO ()
 testGroupHistoryFileCancel =
@@ -6862,13 +6863,14 @@ testGroupHistoryQuotes =
       cath ##> "/_get chat #1 count=100"
       r <- chat' <$> getTermLine cath
       r
-        `shouldContain` [ ((0, "ALICE"), Nothing),
-                          ((0, "BOB"), Nothing),
-                          ((0, "1"), Just (0, "ALICE")),
-                          ((0, "2"), Just (0, "BOB")),
-                          ((0, "3"), Just (0, "ALICE")),
-                          ((0, "4"), Just (0, "BOB"))
-                        ]
+        `shouldSatisfy` isSubsequenceOf
+          [ ((0, "ALICE"), Nothing),
+            ((0, "BOB"), Nothing),
+            ((0, "1"), Just (0, "ALICE")),
+            ((0, "2"), Just (0, "BOB")),
+            ((0, "3"), Just (0, "ALICE")),
+            ((0, "4"), Just (0, "BOB"))
+          ]
 
 testGroupHistoryDeletedMessage :: HasCallStack => TestParams -> IO ()
 testGroupHistoryDeletedMessage =
@@ -6970,7 +6972,7 @@ testGroupHistoryDisappearingMessage =
 
       cath ##> "/_get chat #1 count=100"
       r1 <- chat <$> getTermLine cath
-      r1 `shouldContain` [(0, "1"), (0, "2"), (0, "3"), (0, "4")]
+      r1 `shouldSatisfy` isSubsequenceOf [(0, "1"), (0, "2"), (0, "3"), (0, "4")]
 
       threadDelay 11000000
       concurrentlyN_
@@ -6990,7 +6992,7 @@ testGroupHistoryDisappearingMessage =
 
       cath ##> "/_get chat #1 count=100"
       r2 <- chat <$> getTermLine cath
-      r2 `shouldContain` [(0, "1"), (0, "4")]
+      r2 `shouldSatisfy` isSubsequenceOf [(0, "1"), (0, "4")]
       r2 `shouldNotContain` [(0, "2")]
       r2 `shouldNotContain` [(0, "3")]
 
@@ -7101,7 +7103,7 @@ testGroupHistoryUnknownMember =
 
       dan ##> "/_get chat #1 count=100"
       r <- chat <$> getTermLine dan
-      r `shouldContain` [(0, "hi from alice"), (0, "hi from bob"), (0, "hi from cath")]
+      r `shouldSatisfy` isSubsequenceOf [(0, "hi from alice"), (0, "hi from bob"), (0, "hi from cath")]
 
       dan ##> "/ms team"
       dan

tests/ChatTests/Profiles.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -14,7 +15,7 @@ import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (concurrently_)
+import Control.Concurrent.Async (concurrently, concurrently_)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
@@ -916,12 +917,13 @@ testUserBadgeGroupLinkJoiner ps = do
       memberBadgeHeader alice "team" "bob" `shouldReturn` Just ("R", BSActive)
       bob ##> "/_start"
       bob <## "chat started"
-      bob <## "subscribed 1 connections on server localhost"
       concurrentlyN_
         [ alice <## "#team: bob joined the group",
-          do
-            bob <## "#team: joining the group..."
-            bob <## "#team: you joined the group"
+          bob
+            <### [ "subscribed 1 connections on server localhost",
+                   "#team: joining the group...",
+                   "#team: you joined the group"
+                 ]
         ]
       memberBadgeHeader alice "team" "bob" `shouldReturn` Just ("CG", BSActive)
 
@@ -986,8 +988,7 @@ testUserBadgeInvitedIntroduced ps = do
       bob <## "chat stopped"
       cath ##> "/_start"
       cath <## "chat started"
-      cath <## "subscribed 2 connections on server localhost"
-      cath <## "#team: alice added bob (Bob) to the group (connecting...)"
+      cath <### ["subscribed 2 connections on server localhost", "#team: alice added bob (Bob) to the group (connecting...)"]
       memberBadgeHeader cath "team" "bob" `shouldReturn` Just ("CG", BSActive)
 
 testUserBadgeInvitingHost :: HasCallStack => TestParams -> IO ()
@@ -5148,14 +5149,24 @@ testShortLinkInvitationChangeUser = testChat2 aliceProfile bobProfile test
         <### [ "alisa: connection started",
                WithTime "@alisa hello"
              ]
-      concurrently_
-        (bob <## "alisa: contact is connected")
-        ( alice
-            <### [ WithTime "bob> hello",
-                   "bob (Bob): contact is connected"
-                 ]
-        )
-      alice <##> bob
+      (_, connectedFirst) <-
+        concurrently
+          (bob <## "alisa: contact is connected")
+          ( getTermLine alice >>= \case
+              "bob (Bob): contact is connected" -> do
+                alice <## "bob: standard end-to-end encryption enabled"
+                alice <# "bob> hello"
+                pure True
+              l -> do
+                dropTime l `shouldBe` "bob> hello"
+                alice <## "bob (Bob): contact is connected"
+                pure False
+          )
+      alice #> "@bob hi"
+      bob <# "alisa> hi"
+      bob #> "@alisa hey"
+      when connectedFirst $ alice <## "bob: quantum resistant end-to-end encryption enabled"
+      alice <# "bob> hey"
 
 testShortLinkAddressChangeProfile :: HasCallStack => TestParams -> IO ()
 testShortLinkAddressChangeProfile = testChat2 aliceProfile bobProfile test

tests/SchemaDump.hs

@@ -103,7 +103,7 @@ testSchemaMigrations = do
 
 testVerifyStrict :: IO ()
 testVerifyStrict = do
-  Right st <- createDBStore (DBOpts testDB chatDBFunctions "" False True TQOff) Store.migrations (MigrationConfig MCConsole Nothing)
+  Right st <- createDBStore (DBOpts testDB chatDBFunctions "" False True TQOff) Store.migrations (MigrationConfig MCError Nothing)
   withConnection st (`DB.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name != 'sqlite_sequence' AND sql NOT LIKE '% STRICT'")
     `shouldReturn` ([] :: [Only Text])