diff --git a/apps/simplex-badge-service/src/BadgeService/Log.hs b/apps/simplex-badge-service/src/BadgeService/Log.hs index a2f54f4420..6ac7cd48a2 100644 --- a/apps/simplex-badge-service/src/BadgeService/Log.hs +++ b/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)) diff --git a/cabal.project b/cabal.project index 746a09c590..e2e0c01f3f 100644 --- a/cabal.project +++ b/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 diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index d819d55b3b..e8d29583f6 100644 --- a/scripts/nix/sha256map.nix +++ b/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"; } diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index b218305adb..f347db40ee 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index dfcd1005ab..e7738cddc2 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/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 = diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 63886dcadb..235c61ce7b 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/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) diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 7264a65bbc..c3a0a5a321 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/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 diff --git a/tests/Bots/BadgeService/GroupIntegrationTests.hs b/tests/Bots/BadgeService/GroupIntegrationTests.hs index 8b4cbc249a..0a632b46b5 100644 --- a/tests/Bots/BadgeService/GroupIntegrationTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 65c5cc3017..0421151050 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/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 diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 22d73f72ea..c33d9df230 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/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' to send messages" + let merged = ["contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'", "use @'SimpleX Directory' 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" diff --git a/tests/ChatTests/ChatRelays.hs b/tests/ChatTests/ChatRelays.hs index baf8d10d16..7923a6546b 100644 --- a/tests/ChatTests/ChatRelays.hs +++ b/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 = diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 81f0f5d9e2..f56ba62102 100644 --- a/tests/ChatTests/Groups.hs +++ b/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 diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index db16226989..eeefbe8162 100644 --- a/tests/ChatTests/Profiles.hs +++ b/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 diff --git a/tests/SchemaDump.hs b/tests/SchemaDump.hs index fecebfc8b2..5b206f2ef8 100644 --- a/tests/SchemaDump.hs +++ b/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])