From df95de8a2c2e2872357f8bf53f6cb335bc845e99 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 7 Oct 2026 08:12:02 +0100 Subject: [PATCH] tests, fix: execute in parallel, send connected events after creating chat items, fix race when merging multiple members to one contact (#7500) * tests: execute in parallel * remove race in terminal * fix some tests * stop chat controller on exit * fix more tests * fix tests * query plans * update simplexmq * update direct-sqlcipher * fix tests * query plans * ios: update core * fix tests * update simplexmq and direct-sqlcipher, fixes * simplexmq * update simplexmq * parallel channel tests * update tests * fix tests * fix tests * query plans * fix test * more tests in CI * use ram drive in CI * fix tests, fix directory deleting voice file before it is uploaded * fix query * fix query to use index * link contact and channel owner profile when connecting via a signed link * update simplexmq, fix ghc 8.10.7 * fix tests * avoid double stop * query plans * fix more test races * more test fixes * fix queries * fixes * more fixes --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- .github/workflows/build.yml | 8 + apps/simplex-directory-service/Main.hs | 2 +- .../src/Directory/Events.hs | 7 + .../src/Directory/Service.hs | 13 +- cabal.project | 4 +- plans/2026-09-13-parallel-tests.md | 81 +++ scripts/nix/sha256map.nix | 4 +- simplex-chat.cabal | 3 +- src/Simplex/Chat/Core.hs | 28 +- src/Simplex/Chat/Library/Subscriber.hs | 17 +- src/Simplex/Chat/Store/Direct.hs | 2 +- src/Simplex/Chat/Store/Groups.hs | 28 +- .../SQLite/Migrations/agent_query_plans.txt | 165 +++++- .../SQLite/Migrations/chat_query_plans.txt | 26 +- src/Simplex/Chat/Types.hs | 7 + tests/Bots/BadgeService/BotTests.hs | 112 +++-- .../BadgeService/GroupIntegrationTests.hs | 7 +- tests/Bots/BadgeService/WebTests.hs | 43 +- tests/Bots/BroadcastTests.hs | 16 +- tests/Bots/DirectoryTests.hs | 469 +++++++++--------- tests/ChatClient.hs | 163 ++++-- tests/ChatTests/ChatRelays.hs | 4 +- tests/ChatTests/DBUtils/Postgres.hs | 1 + tests/ChatTests/DBUtils/SQLite.hs | 1 + tests/ChatTests/Direct.hs | 258 +++++----- tests/ChatTests/Files.hs | 413 ++++++++------- tests/ChatTests/Forward.hs | 110 ++-- tests/ChatTests/Groups.hs | 430 +++++++++------- tests/ChatTests/Local.hs | 19 +- tests/ChatTests/Names.hs | 22 +- tests/ChatTests/Profiles.hs | 321 ++++++------ tests/ChatTests/Utils.hs | 43 +- tests/RemoteTests.hs | 54 +- tests/SchemaDump.hs | 7 +- tests/Test.hs | 52 +- 35 files changed, 1773 insertions(+), 1167 deletions(-) create mode 100644 plans/2026-09-13-parallel-tests.md diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d92e2507c9..c20fce8c25 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -360,6 +360,14 @@ jobs: sudo chmod -R 777 dist-newstyle ~/.cabal sudo chown -R $(id -u):$(id -g) dist-newstyle ~/.cabal + - name: Mount RAM disk for tests + if: matrix.should_run == true && matrix.arch == 'x86_64' + shell: bash + run: | + mkdir -p tests/tmp + sudo mount -t tmpfs -o size=512M tmpfs tests/tmp + sudo chown $(id -u):$(id -g) tests/tmp + - name: Run tests if: matrix.should_run == true && matrix.arch == 'x86_64' timeout-minutes: 120 diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index f771199dea..228c9329c2 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -12,4 +12,4 @@ main = do opts@DirectoryOpts {runCLI} <- welcomeGetOpts if runCLI then directoryServiceCLI opts - else directoryService opts terminalChatConfig + else newServiceState opts >>= directoryService opts terminalChatConfig diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index bc84ab86e1..7d6fc609b0 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -66,6 +66,7 @@ data DirectoryEvent | DEItemEditIgnored Contact | DEItemDeleteIgnored Contact | DEContactCommand Contact ChatItemId ADirectoryCmd + | DEVoiceUploadEnded FilePath | DELogChatResponse Text deriving (Show) @@ -110,11 +111,17 @@ crDirectoryEvent_ = \case where ciId = chatItemId' ci err = ADC SDRUser DCUnknownCommand + CEvtSndFileCompleteXFTP {chatItem, fileTransferMeta} -> voiceUploadEnded (Just chatItem) fileTransferMeta + CEvtSndFileError {chatItem_, fileTransferMeta} -> voiceUploadEnded chatItem_ fileTransferMeta CEvtMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage CEvtChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors) _ -> Nothing where pending m = memberStatus m == GSMemPendingApproval + voiceUploadEnded :: Maybe AChatItem -> FileTransferMeta -> Maybe DirectoryEvent + voiceUploadEnded ci_ FileTransferMeta {filePath} = case ci_ of + Just (AChatItem _ SMDSnd _ ChatItem {content = CISndMsgContent MCVoice {}}) -> Just $ DEVoiceUploadEnded filePath + _ -> Nothing data DirectoryRole = DRUser | DRAdmin | DRSuperUser diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index f10cbf44fd..76c3f43400 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -12,7 +12,9 @@ {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Directory.Service - ( welcomeGetOpts, + ( ServiceState (..), + welcomeGetOpts, + newServiceState, directoryService, directoryServiceCLI, ) @@ -245,9 +247,8 @@ directoryCommands = where idParam = Just "" -directoryService :: DirectoryOpts -> ChatConfig -> IO () -directoryService opts cfg = do - env@ServiceState {eventQ} <- newServiceState opts +directoryService :: DirectoryOpts -> ChatConfig -> ServiceState -> IO () +directoryService opts cfg env@ServiceState {eventQ} = do let chatHooks = defaultChatHooks { preStartHook = Just $ directoryPreStartHook opts, @@ -340,6 +341,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o SDRUser -> deUserCommand ct ciId cmd SDRAdmin -> deAdminCommand ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd + DEVoiceUploadEnded filePath -> void (try $ removeFile filePath :: IO (Either SomeException ())) DELogChatResponse r -> logInfo r where groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt $ simplexChatContact cReq) strEncodeTxt sLnk_ @@ -651,9 +653,8 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o case voiceResult of Right r -> case lines r of (filePath : durationStr : _) - | not (null filePath), Just duration <- readMaybe durationStr -> do + | not (null filePath), Just duration <- readMaybe durationStr -> sendComposedMessageFile cc sendRef Nothing (MCVoice "" duration) (CF.plain filePath) - void (try $ removeFile filePath :: IO (Either SomeException ())) _ -> logError "voice captcha generator: unexpected output" Left e -> logError $ "voice captcha generator error: " <> tshow e diff --git a/cabal.project b/cabal.project index 2641ca72c1..ed446d492c 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: 4ab5376a6e7032579d90ec17a634a2bf85104176 + tag: c0a1b7bd2d79c4af5163d9a863cb0780f556d7a9 source-repository-package type: git @@ -31,7 +31,7 @@ source-repository-package source-repository-package type: git location: https://github.com/simplex-chat/direct-sqlcipher.git - tag: f814ee68b16a9447fbb467ccc8f29bdd3546bfd9 + tag: 2330df3dc8c4b660674d3c02d76bb86f66c2abee source-repository-package type: git diff --git a/plans/2026-09-13-parallel-tests.md b/plans/2026-09-13-parallel-tests.md new file mode 100644 index 0000000000..461c970b84 --- /dev/null +++ b/plans/2026-09-13-parallel-tests.md @@ -0,0 +1,81 @@ +# Parallel test execution + +Every test gets its own ports and its own directory, so hspec runs the tree +concurrently in one process with `parallel` and `--jobs`. + +## Decisions + +- `TestParams` gains `portBase :: Int`. A pool of bases `[7000, 7010 .. 8990]` + is created in `main`; `testBracket` takes a base for the test and returns it + after. Ports of a test: SMP `base + 1`, XFTP `base + 2`, second SMP `base + 3`, + remote host `base + 4`. +- `TestCC` carries `testParams`. `class HasTestParams` with instances for + `TestParams` and `TestCC` lets helpers take either, so closure tests reach + the environment through a client: `tmpFile bob "test.jpg"`, `smpPort alice`, + `withXFTPServer alice`. +- Client configs keep the literal ports 7001, 7002 and 7003 as the logical + layout. `startTestChat_` maps them to the test's ports in `smpServers`, + `xftpServers` and `shortLinkPresetServers`. Expected output uses the real + ports through `smpServerStr`, `xftpServerStr`, `smpPort`, `xftpPort`, + `smpPort2`. +- Servers take the test: `smpServerCfg ps`, `withSmpServer ps`, + `withSmpServerAndNames ps`, `xftpServerConfig ps`, `withXFTPServer ps`. + The XFTP server stays under test control, since tests exercise its restarts. + Its files and store log are under the test directory. +- `tests/tmp` is created once around the whole run (`withTmpFiles` in `main`) + and each test works in `withTempDirectory "tests/tmp"`. Paths in tests are + `tmpDir` and `tmpFile` of the client or params. +- `xftpCLI` runs the test binary as a subprocess with the first argument + `xftp-cli`, because `withArgs` and `capture_` are process-global. +- Test suite `ghc-options` gain `-rtsopts "-with-rtsopts=-N"`. +- `parallel` wraps the tree. Sequential remain: schema dump, API docs, + "Save query plans" (last item, reads the maps after every test). +- Postgres: the database is created once (`beforeAll_`/`afterAll_`); the + client schema prefix includes the test directory name. +- Bots started through `directoryService`, `badgeService` and + `simplexChatCore` take `coreOptions` and the config from `testPortsCfg`. +- `TestTerminal` wraps the virtual terminal and writes the cursor row to + `termQ` on `PutLn`. +- The "no output left" check runs in the bracket body; `stopTestChat` stops + the client in a separate thread with a 60 s limit and keeps the store open + after the limit. +- Per-test limit 180 s; the "channels" group is `sequential`; `@@@` waits + 500 ms. TTL and timed-message tests use multi-second TTLs; ratchet + desynchronization helpers turn receipts off. + +## Status + +Implemented; the suite builds. Runs so far: file tests, 39 examples in 111 s +with `-j 8` on 4 cores at -O0, one timing failure per run, a different test +each time. "error receiving file" (`testXFTPRcvError`) fails intermittently +even alone with `chat db error: SERcvFileInvalidDescrPart`: `appendRcvFD` +receives a description part for a description that is already complete, so +the part arrives twice. The first block stops bob right after alice's upload +completes, without waiting for bob to process the description, which is the +likely source of the duplicate after his restart. The race predates this +change; `-N` and load make it more likely. + +Direct, schema dump, protocol and names groups: 178 examples in 331 s with +`-j 6`, 11 failures. Two are environmental on this machine: the schema dump +cannot overwrite root-owned `chat_schema.sql`, and `encrypt/decrypt database` +needs `direct-sqlcipher +openssl`, which CI sets and the local build lacks. +The rest pass alone and fail under load: expiration and timed-message tests +with second-scale TTLs, the client-timeout retry test, and cases where a +line already consumed reappears at the end of the test, which points at the +window diff in `readTerminalOutput` under batched terminal updates. + +Profile tests at the default job count (4 cores): 105 examples in 439 s, +2 failures, both timed-message tests with second-scale TTLs. + +## Mechanics + +- `tests/ChatTests/DBUtils/*.hs`: `portBase` field. +- `tests/ChatClient.hs`: `HasTestParams`, port and path helpers, server + configs and brackets as functions of the test, port mapping in + `startTestChat_`, `withTmpFiles` without removal per test. +- `tests/Test.hs`: port pool, `xftp-cli` subcommand, `parallel`, `withTmpFiles` + around `hspec`. +- `tests/SchemaDump.hs`: `withTmpFiles` wrappers removed. +- `tests/ChatTests/Utils.hs`: `xftpCLI` subprocess. +- Test modules: literal `tests/tmp` paths, server ports and XFTP brackets + rewritten through the helpers. diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 6591228fae..1795f6e865 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,7 +1,7 @@ { - "https://github.com/simplex-chat/simplexmq.git"."4ab5376a6e7032579d90ec17a634a2bf85104176" = "0n6vf6ikccrjif32mq0nkivyz12f1psxccbp9zrcc0nqgmgihwvc"; + "https://github.com/simplex-chat/simplexmq.git"."c0a1b7bd2d79c4af5163d9a863cb0780f556d7a9" = "0l10gc46l1i1wwalapg4wa0y1x3j4l4465242701k9lvvgywjh9z"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; - "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; + "https://github.com/simplex-chat/direct-sqlcipher.git"."2330df3dc8c4b660674d3c02d76bb86f66c2abee" = "11pfj1vqsjdl26nplkr2l6z1xj7cn153qijj5gknmlzq3krn7x1i"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/aeson.git"."aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b" = "0jz7kda8gai893vyvj96fy962ncv8dcsx71fbddyy8zrvc88jfrr"; "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 9bd6019b1e..daa16691e6 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -779,7 +779,7 @@ test-suite simplex-chat-test default-extensions: StrictData -- add -fhpc to ghc-options below to run tests with coverage - ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts "-with-rtsopts=-N" build-depends: QuickCheck ==2.14.* , aeson ==2.2.* @@ -842,5 +842,6 @@ test-suite simplex-chat-test build-depends: bytestring ==0.10.* , hspec ==2.7.* + , hspec-core ==2.7.* , process >=1.6 && <1.6.18 , text >=1.2.4.0 && <1.3 diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index ccf6f15bdb..942b07dea0 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -14,7 +14,7 @@ module Simplex.Chat.Core where import Control.Concurrent (forkIO) -import Control.Exception (mask, onException, throwTo) +import Control.Exception (fromException, mask, onException, throwTo) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -93,16 +93,22 @@ 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 = 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) - -- throwTo waits while the callback is masked, so an outside interrupt cancels it from a forked thread. - -- A /_stop sent from the callback ends a1 first, which leaves the callback running. - mask $ \restore -> do - a2 <- asyncWithUnmask $ \unmask -> unmask (chat u cc) - let cancelCallback = poll a1 >>= \r -> when (isNothing r) $ void $ forkIO $ throwTo (asyncThreadId a2) AsyncCancelled - restore (waitEither_ a1 a2) `onException` cancelCallback + | otherwise = do + a1 <- runReaderT (startChatController True True False) cc `onException` stopChatController cc + flip finally (stopUnlessCancelled a1) $ do + when (chatRelay && not testView) $ askCreateRelayAddress cc u chatRelayServer headless + forM_ (postStartHook chatHooks) ($ cc) + -- throwTo waits while the callback is masked, so an outside interrupt cancels it from a forked thread. + -- A /_stop sent from the callback ends a1 first, which leaves the callback running. + mask $ \restore -> do + a2 <- asyncWithUnmask $ \unmask -> unmask (chat u cc) + let cancelCallback = poll a1 >>= \r -> when (isNothing r) $ void $ forkIO $ throwTo (asyncThreadId a2) AsyncCancelled + restore (waitEither_ a1 a2) `onException` cancelCallback + where + stopUnlessCancelled a1 = + poll a1 >>= \case + Just (Left e) | fromException e == Just AsyncCancelled -> pure () + _ -> stopChatController cc sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse) sendChatCmdStr cc s = runReaderT (execChatCommand CSLocal (encodeUtf8 $ T.pack s) 0) cc diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 71337a6b0e..3f0e53fd8a 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -659,7 +659,6 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag ct' = ct {activeConn = Just conn'} :: Contact -- [incognito] print incognito profile used for this contact incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) - toView $ CEvtContactConnected user ct' (fmap fromLocalProfile incognitoProfile) let createE2EItem = createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ Just pqEnc) Nothing -- TODO [short links] get contact request by contactRequestId, check encryption (UserContactRequest.pqSupport)? when (directOrUsed ct') $ case (preparedContact ct', contactRequestId' ct') of @@ -674,6 +673,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag withStore' (\db -> getContactRequest' db user connReqId) >>= \case Just UserContactRequest {pqSupport} | CR.pqSupportToEnc pqSupport == pqEnc -> pure () _ -> createE2EItem + toView $ CEvtContactConnected user ct' (fmap fromLocalProfile incognitoProfile) when (contactConnInitiated conn') $ do probeMatchingMembers ct' (contactConnIncognito ct') withStore' $ \db -> resetContactConnInitiated db user conn' @@ -884,7 +884,6 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag pure gInfo {membership = membership {memberStatus = GSMemConnected}} else pure gInfo pure (m {memberStatus = GSMemConnected}, gInfo') - toView $ CEvtUserJoinedGroup user gInfo' m' when (isRelay membership) $ do cc <- ask atomically $ channelProfileUpdated cc groupId groupProfile @@ -898,10 +897,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag let prepared = preparedGroup gInfo'' unless (isJust prepared) $ createGroupFeatureItems user cd CIRcvGroupFeature gInfo'' memberConnectedChatItem gInfo'' scopeInfo m'' + toView $ CEvtUserJoinedGroup user gInfo' m' let welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId = mId} -> mId) <$> prepared unless (memberPending membership || isJust welcomeMsgId_) $ maybeCreateGroupDescrLocal gInfo'' m'' ) - (memberConnectedChatItem gInfo'' scopeInfo m'') + ( do + memberConnectedChatItem gInfo'' scopeInfo m'' + toView $ CEvtUserJoinedGroup user gInfo' m' + ) where firstConnectedHost | useRelays' gInfo = do @@ -2897,7 +2900,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag pure m' Just mContactId -> do mCt <- withStore $ \db -> getContact db cxt user mContactId - if canUpdateProfile mCt + if contactUpdatableFromMember mCt then do (m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt p' unless (muteEventInChannel gInfo m') $ do @@ -2906,12 +2909,6 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag toView $ CEvtContactUpdated user mCt ct' pure m' else pure m - where - canUpdateProfile ct - | not (contactActive ct) = True - | otherwise = case contactConn ct of - Nothing -> True - Just conn -> not (connReady conn) || (authErrCounter conn >= 1) | otherwise = pure m where diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 0e68221056..76029b4a4f 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -1169,6 +1169,6 @@ getDirectChatTTL db ctId = getUserContactsToExpire :: DB.Connection -> User -> Int64 -> IO [ContactId] getUserContactsToExpire db User {userId} globalTTL = - map fromOnly <$> DB.query db ("SELECT contact_id FROM contacts WHERE user_id = ? AND chat_item_ttl > 0" <> cond) (Only userId) + map fromOnly <$> DB.query db ("SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0" <> cond <> ")") (Only userId) where cond = if globalTTL == 0 then "" else " OR chat_item_ttl IS NULL" diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index f9cb76782a..66a5dc7783 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -3105,10 +3105,10 @@ associateContactWithMemberRecord db [sql| UPDATE group_members - SET contact_id = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND group_member_id = ? + SET contact_id = ?, local_display_name = ?, contact_profile_id = ?, updated_at = ? + WHERE (user_id = ? AND group_id = ? AND group_member_id = ?) OR contact_id = ? |] - (contactId, currentTs, userId, groupId, groupMemberId) + (contactId, memLDN, memProfileId, currentTs, userId, groupId, groupMemberId, contactId) DB.execute db [sql| @@ -3412,7 +3412,16 @@ setMemberContactStartedConnection db Contact {contactId} = do (BI True, currentTs, contactId) updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember -updateMemberProfile db cxt user@User {userId} m p' = do +updateMemberProfile db cxt user m@GroupMember {memberContactId} p' = case memberContactId of + Nothing -> updateUnlinkedMemberProfile db cxt user m p' + Just ctId -> do + ct <- getContact db cxt user ctId + if contactUpdatableFromMember ct + then fst <$> updateContactMemberProfile db cxt user m ct p' + else pure m + +updateUnlinkedMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember +updateUnlinkedMemberProfile db cxt user@User {userId} m p' = do currentTs <- liftIO getCurrentTime badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) (memberProfile m) p' let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing @@ -3494,8 +3503,7 @@ createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo { createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe ContactId -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do currentTs <- liftIO getCurrentTime - let memberProfile = profileFromName $ nameFromMemberId memberId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile currentTs + (localDisplayName, profileId) <- maybe (newOwnerProfile currentTs) contactNameAndProfile contactId_ indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -3515,6 +3523,12 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI getGroupMemberById db cxt user groupMemberId where VersionRange minV maxV = vr cxt + newOwnerProfile currentTs = do + (ldn, pId, _) <- createNewMemberProfile_ db cxt user (profileFromName $ nameFromMemberId memberId) currentTs + pure (ldn, pId) + contactNameAndProfile ctId = do + Contact {localDisplayName = ldn, profile = LocalProfile {profileId = pId}} <- getContact db cxt user ctId + pure (ldn, pId) -- Intro refreshes only profile / status / peer version. Role and key stay owner-authoritative -- (the owner-signed roster for members/moderators/admins, link data for owners), so taking either from @@ -3650,7 +3664,7 @@ getGroupChatTTL db gId = getUserGroupsToExpire :: DB.Connection -> User -> Int64 -> IO [GroupId] getUserGroupsToExpire db User {userId} globalTTL = - map fromOnly <$> DB.query db ("SELECT group_id FROM groups WHERE user_id = ? AND chat_item_ttl > 0" <> cond) (Only userId) + map fromOnly <$> DB.query db ("SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0" <> cond <> ")") (Only userId) where cond = if globalTTL == 0 then "" else " OR chat_item_ttl IS NULL" diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt index 833a1ae602..7c2e56c2b7 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt @@ -293,6 +293,16 @@ Query: Plan: SEARCH connections USING PRIMARY KEY (conn_id=?) +Query: + SELECT user_id FROM users u + WHERE u.deleted = ? + AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) + +Plan: +SCAN u +CORRELATED SCALAR SUBQUERY 1 +SEARCH c USING COVERING INDEX idx_connections_user (user_id=?) + Query: SELECT user_id FROM users u WHERE u.user_id = ? @@ -515,6 +525,23 @@ Query: Plan: SEARCH conn_confirmations USING INDEX idx_conn_confirmations_conn_id (conn_id=?) +Query: + SELECT conn_id, ( + SELECT processed_ratchet_key_hash_id + FROM processed_ratchet_key_hashes + WHERE conn_id = c.conn_id + ORDER BY processed_ratchet_key_hash_id DESC + LIMIT 1 OFFSET ? + ) AS max_excess_id + FROM processed_ratchet_key_hashes c + GROUP BY conn_id + HAVING COUNT(*) > ? + +Plan: +SCAN c USING COVERING INDEX idx_processed_ratchet_key_hashes_conn_id +CORRELATED SCALAR SUBQUERY 1 +SEARCH processed_ratchet_key_hashes USING COVERING INDEX idx_processed_ratchet_key_hashes_conn_id (conn_id=?) + Query: SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version FROM conn_confirmations @@ -587,6 +614,15 @@ Query: Plan: SEARCH address_ratchet_keys USING INDEX idx_address_ratchet_keys (conn_id=? AND ratchet_key_id=?) +Query: + UPDATE rcv_messages + SET receive_attempts = receive_attempts + 1 + WHERE conn_id = ? AND internal_id = ? + RETURNING receive_attempts + +Plan: +SEARCH rcv_messages USING COVERING INDEX idx_rcv_messages_conn_id_internal_id (conn_id=? AND internal_id=?) + Query: DELETE FROM address_ratchet_keys WHERE conn_id = ? @@ -611,6 +647,39 @@ Query: Plan: SEARCH conn_confirmations USING COVERING INDEX idx_conn_confirmations_conn_id (conn_id=?) +Query: + DELETE FROM encrypted_rcv_message_hashes + WHERE encrypted_rcv_message_hash_id IN ( + SELECT encrypted_rcv_message_hash_id + FROM encrypted_rcv_message_hashes + WHERE created_at < ? + ORDER BY created_at ASC + LIMIT ? + ) + +Plan: +SEARCH encrypted_rcv_message_hashes USING INTEGER PRIMARY KEY (rowid=?) +LIST SUBQUERY 1 +SEARCH encrypted_rcv_message_hashes USING COVERING INDEX idx_encrypted_rcv_message_hashes_created_at (created_at 0 Plan: SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?) @@ -7382,11 +7390,7 @@ Query: SELECT chat_item_id FROM chat_items WHERE group_scope_tag = 'member_suppo Plan: SCAN chat_items -Query: SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE '!2 SB-8H8V3-PF8CV-PQMA2-A54M3!%' -Plan: -SCAN chat_items - -Query: SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE '!2 SB-Y14GX-Z83KW-0E3PK-DEN7X!%' +Query: SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE ? || '%' Plan: SCAN chat_items @@ -7684,6 +7688,10 @@ Query: SELECT member_xcontact_id, member_welcome_shared_msg_id FROM group_member Plan: SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?) +Query: SELECT next_wake_at, badge_purchase_id FROM badge_purchases +Plan: +SCAN badge_purchases + Query: SELECT note_folder_id FROM note_folders WHERE user_id = ? Plan: SEARCH note_folders USING COVERING INDEX note_folders_user_id (user_id=?) @@ -7756,6 +7764,10 @@ Query: SELECT shared_msg_id FROM chat_items WHERE shared_msg_id IS NOT NULL ORDE Plan: SCAN chat_items +Query: SELECT short_descr FROM contact_profiles WHERE display_name = ? LIMIT 1 +Plan: +SEARCH contact_profiles USING INDEX contact_profiles_index (display_name=?) + Query: SELECT should_sync FROM connections_sync WHERE connections_sync_id = 1 Plan: SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?) diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 282d6b2fda..ce5879538b 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -316,6 +316,13 @@ contactActive Contact {contactStatus} = contactStatus == CSActive contactDeleted :: Contact -> Bool contactDeleted Contact {contactStatus} = contactStatus == CSDeleted || contactStatus == CSDeletedByUser +contactUpdatableFromMember :: Contact -> Bool +contactUpdatableFromMember ct + | not (contactActive ct) = True + | otherwise = case contactConn ct of + Nothing -> True + Just conn -> not (connReady conn) || (authErrCounter conn >= 1) + contactSecurityCode :: Contact -> Maybe SecurityCode contactSecurityCode Contact {activeConn} = connectionCode =<< activeConn diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 2f2dade67d..129824fed8 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -23,7 +23,8 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import ChatClient import ChatTests.DBUtils import ChatTests.Utils -import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, cancel) import Control.Concurrent.STM (TQueue, atomically, readTMVar) import Control.Monad (forM_, void, when) import Control.Exception (finally) @@ -50,8 +51,9 @@ import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Chat.Bot.Store (withDB') import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) -import Simplex.Chat.Options (CoreChatOpts (..)) +import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options.DB +import Simplex.Messaging.Agent (disposeAgentClient) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) @@ -131,16 +133,16 @@ testIssuerKeyIdx :: Int testIssuerKeyIdx = 1 mkBadgeServiceOpts :: TestParams -> BBSSecretKey -> BadgeServiceOpts -mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey = +mkBadgeServiceOpts ps secretKey = BadgeServiceOpts { coreOptions = - testCoreOpts + coreOpts { dbOptions = (dbOptions testCoreOpts) #if defined(dbPostgres) - {dbSchemaPrefix = "client_" <> serviceDbPrefix} + {dbSchemaPrefix = testSchemaPrefix ps serviceDbPrefix} #else - {dbFilePrefix = ps serviceDbPrefix} + {dbFilePrefix = tmpPath ps serviceDbPrefix} #endif }, serviceName = badgeBotName, @@ -151,6 +153,8 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey = issuerKey = Right (Just BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey}), testing = True } + where + (_, ChatOpts {coreOptions = coreOpts}) = testPortsCfg ps testCfg testOpts -- | The clock tracks real time plus a test-controlled offset rather than freezing it, so a sleeping worker still waits the correct real duration. newtype TestClock = TestClock (IORef NominalDiffTime) @@ -190,7 +194,9 @@ withBadgeServiceEnv ps test = do let opts = mkBadgeServiceOpts ps sk svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk, badgeCurrentTime = testClockTime clock} withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () - runBadgeService svcCfg opts $ \_ -> pure () + -- First start: badge service takes the CreateMyAddress branch. + runBadgeService ps svcCfg opts $ \_ -> pure () + -- Reopen the DB to read the link the service created. bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do bs <## "subscribed 1 connections on server localhost" bs ##> "/sa" @@ -201,7 +207,8 @@ withBadgeServiceEnv ps test = do pure sLink let clientCfg = svcCfg {badgeServiceAddress = Just $ either (error . ("bad badge service address: " <>)) id $ strDecode (B.pack bsLink)} - runBadgeService svcCfg opts $ \env -> do + -- Second start: badge service takes the ShowMyAddress branch, then serves the test body. + runBadgeService ps svcCfg opts $ \env -> do cc <- atomically $ readTMVar $ serviceCC env test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc} @@ -227,14 +234,16 @@ issueCodeAs cc badgeType months status = _ -> error $ "unexpected issue response: " <> T.unpack response r -> error $ "issue failed: " <> show (() <$ r) --- | The post-start hook fills serviceCC once the address exists, so the test waits on it rather than on a fixed delay that would race with startup and let one start's address output arrive during the next test. -runBadgeService :: ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO () -runBadgeService cfg opts action = do +-- | The post-start hook fills serviceCC once the address exists, so waiting on it is the service +-- being ready. A fixed delay here raced with startup and left the address output of one start +-- arriving during the next test. +runBadgeService :: TestParams -> ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO () +runBadgeService ps cfg opts action = do env <- newServiceState - t <- forkIO $ badgeService opts cfg env + t <- async $ badgeService opts (fst $ testPortsCfg ps cfg testOpts) env ready <- timeout 30000000 $ atomically $ readTMVar $ serviceCC env - when (isNothing ready) $ killThread t >> error "badge service did not start" - action env `finally` killThread t + when (isNothing ready) $ cancel t >> error "badge service did not start" + action env `finally` (cancel t >> atomically (readTMVar $ serviceCC env) >>= disposeAgentClient . smpAgent) codeArg :: BadgeCode -> String codeArg = T.unpack . formatBadgeCode @@ -501,11 +510,14 @@ testMultiUseRepeatAfterExpiry ps = redeemFirstBadge alice code rows <- ledgerRows (chatController alice) "badge_ledger" setClockAt bsClock $ dueAtOf rows - alice ##> "/_app activate" - alice <## "ok" - alice <##. "badge alert: support_ended " - alice <##. "1: supporter" - alice <##. "badge alert: support_ended " + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: support_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: support_ended " + ] waitShownBadge (chatController alice) Nothing -- The repeat uses the same purchase key, so the service returns the credential it already issued. alice ##> ("/_redeem_badge_code 1 " <> codeArg code) @@ -787,6 +799,20 @@ redeemFirstBadge alice code = do alice <## "badge redeemed" alice <## "supporter badge - active" alice <##. "expires " + waitWakeArmed (chatController alice) + +waitWakeArmed :: HasCallStack => ChatController -> IO () +waitWakeArmed ChatController {chatStore} = loop (100 :: Int) + where + loop i = do + rows :: [(Maybe UTCTime, Int64)] <- + withTransaction chatStore $ \db -> + DB.query_ db "SELECT next_wake_at, badge_purchase_id FROM badge_purchases" + case rows of + [(Just _, _)] -> pure () + _ + | i == 0 -> error $ "expected one badge purchase with a wake, got " <> show rows + | otherwise -> threadDelay 50000 >> loop (i - 1) testWorkerRenews :: HasCallStack => TestParams -> IO () testWorkerRenews ps = @@ -987,11 +1013,14 @@ testWorkerRetiresExpired ps = bob <## currentChatVRangeInfo rows <- ledgerRows (chatController alice) "badge_ledger" setClockAt bsClock $ dueAtOf rows - alice ##> "/_app activate" - alice <## "ok" - alice <##. "badge alert: support_ended " - alice <##. "1: supporter" - alice <##. "badge alert: support_ended " + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: support_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: support_ended " + ] waitShownBadge (chatController alice) Nothing alice ##> "/p" alice <## "user profile: alice (Alice)" @@ -1033,11 +1062,14 @@ testEndedAlert ps = rows <- ledgerRows (chatController alice) "badge_ledger" let endsAt = dueAtOf rows setClockAt bsClock endsAt - alice ##> "/_app activate" - alice <## "ok" - alice <##. "badge alert: support_ended " - alice <##. "1: supporter" - alice <##. "badge alert: support_ended " + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: support_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: support_ended " + ] pure endsAt withTestChatCfg ps bsClientCfg "alice" $ \alice -> do alice <##. "badge alert: support_ended " @@ -1186,9 +1218,7 @@ testNoCredentialMonthsRanOut ps = rows' <- ledgerRows (chatController alice) "badge_ledger" map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows' `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-2, 0, Just "support")] alice ##> "/_app activate" - alice <## "ok" - alice <##. "1: supporter" - alice <##. "badge alert: support_ended " + alice <### ["ok", StartsWith "1: supporter", StartsWith "badge alert: support_ended "] waitShownBadge (chatController alice) Nothing -- The service issuing nothing while the ledger still owes a month is a fault the client cannot @@ -1315,20 +1345,22 @@ testSnoozedAlertReturns ps = rows <- ledgerRows (chatController alice) "badge_ledger" let endsAt = dueAtOf rows setClockAt bsClock endsAt - alice ##> "/_app activate" - alice <## "ok" - alice <##. "badge alert: support_ended " - alice <##. "1: supporter" - alice <##. "badge alert: support_ended " + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: support_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: support_ended " + ] alice ##> ("/_badge ack 1 1 support_ended on " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt)) alice <##. "1: supporter" alice ##> "/p" alice <## "user profile: alice (Alice)" alice <## "use /p [] to change it" setClockAt bsClock $ addUTCTime (nominalDay + 60) endsAt - alice ##> "/_app activate" - alice <## "ok" - alice <##. "badge alert: support_ended " + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", StartsWith "badge alert: support_ended "] testRenewalKeepsProfileEdits :: HasCallStack => TestParams -> IO () testRenewalKeepsProfileEdits ps = diff --git a/tests/Bots/BadgeService/GroupIntegrationTests.hs b/tests/Bots/BadgeService/GroupIntegrationTests.hs index 1b80adcd13..8b4cbc249a 100644 --- a/tests/Bots/BadgeService/GroupIntegrationTests.hs +++ b/tests/Bots/BadgeService/GroupIntegrationTests.hs @@ -235,6 +235,7 @@ withOwnerJoined ps cc 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"] r <- action alice drainConsole alice pure r @@ -1214,11 +1215,13 @@ deleteItem cc citemId = do -- The member must have received the message before the command can find it. moderateBotItem :: HasCallStack => TestCC -> Text -> IO () moderateBotItem member body = do - void (pollUntil (queryFirst (chatController member) received) :: IO Int64) + void (pollUntil received :: IO Int64) send member ("\\\\ #" <> groupName <> " @" <> botName <> " " <> T.unpack header) where header = T.takeWhile (/= '\n') body - received = "SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE '" <> T.unpack header <> "%'" + received = + withTransaction (chatStore $ chatController member) $ \db -> + listToMaybe . map fromOnly <$> DB.query db "SELECT chat_item_id FROM chat_items WHERE item_sent = 0 AND item_text LIKE ? || '%'" (Only header) waitModeratedItem :: HasCallStack => ChatController -> Int64 -> IO (Int, Maybe Int64, Text) waitModeratedItem cc citemId = diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index b83f4f8f05..15203c75ac 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -25,7 +25,7 @@ import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setInten import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (async, wait) import qualified Control.Concurrent.Async as Async -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar) import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO) import qualified Control.Exception as E import Control.Monad (forM_, join, replicateM, replicateM_, void, when) @@ -81,10 +81,9 @@ import UnliftIO.Temporary (withTempDirectory) #if defined(dbPostgres) import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) -import ChatClient (testDBConnectInfo, testDBConnstr) +import ChatClient (testDBConnstr) import Database.PostgreSQL.Simple (Only (..)) import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #else import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) import Data.String (fromString) @@ -96,21 +95,23 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations #if defined(dbPostgres) withServiceStore :: (DBStore -> IO a) -> IO a -withServiceStore action = - E.bracket_ - (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) - (dropDatabaseAndUser testDBConnectInfo) - $ do - Right st <- createDBStore serviceDBOpts badgeServiceSchemaMigrations (MigrationConfig MCError Nothing) - action st `E.finally` closeDBStore st +withServiceStore action = do + n <- atomicModifyIORef' serviceSchemaCounter (\i -> (i + 1, i)) + Right st <- createDBStore (serviceDBOpts n) badgeServiceSchemaMigrations (MigrationConfig MCError Nothing) + action st `E.finally` closeDBStore st where - serviceDBOpts = + serviceDBOpts :: Int -> DBOpts + serviceDBOpts n = DBOpts { connstr = BC.pack testDBConnstr, - schema = "sx_badge_service_web_test", + schema = "sx_badge_service_web_test_" <> BC.pack (show n), poolSize = 4, createSchema = True } + +serviceSchemaCounter :: IORef Int +serviceSchemaCounter = unsafePerformIO $ newIORef 0 +{-# NOINLINE serviceSchemaCounter #-} #else withServiceStore :: (DBStore -> IO a) -> IO a withServiceStore action = do @@ -1466,11 +1467,17 @@ testHoldReportsTheRowNotTheWake = bounded "hold reports the row" $ withWebApp $ testHold :: Int testHold = 2000000 +awaitWaitingCount :: WebEnv -> Int -> IO () +awaitWaitingCount env n = do + parked <- waitingCount (weWaiters env) + when (parked /= n) $ threadDelay 10000 >> awaitWaitingCount env n + testHoldTimeoutReportsAnUnpublishedChange :: IO () testHoldTimeoutReportsAnUnpublishedChange = bounded "hold timeout" $ withWebAppHolding testHold $ \env client -> do iid <- seedOpenInvoice env started <- getCurrentTime held <- async $ webGet client (invoicePath iid <> "?wait=open") + awaitWaitingCount env 1 threadDelay 50000 expireRow (weStore env) iid r <- wait held @@ -2532,7 +2539,7 @@ testCadenceFollowsTheWaiters = bounded "cadence" $ withStubPoller raceHold $ \_ waitingCount (weWaiters env) `shouldReturn` 0 passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000) held <- async $ webGet client (invoicePath iid <> "?wait=open") - threadDelay 100000 + awaitWaitingCount env 1 passDelayNow poller `shouldReturn` (pWaitingSeconds * 1000000) waitingCount (weWaiters env) `shouldReturn` 1 markPaidAndPublish env iid @@ -2661,9 +2668,13 @@ seedPastWindow st i providerRef provider = do passListing :: IORef StubState -> PollerEnv -> IO () passListing ref poller = runOnePass poller >> clearCalls ref +stderrCaptureLock :: MVar () +stderrCaptureLock = unsafePerformIO $ newMVar () +{-# NOINLINE stderrCaptureLock #-} + -- hDuplicateTo changes stderr's buffering, so put the original setting back. capturingStderr :: IO () -> IO Text -capturingStderr action = do +capturingStderr action = withMVar stderrCaptureLock $ \_ -> do createDirectoryIfMissing True "tests/tmp" withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do let path = dir "stderr.log" @@ -2674,7 +2685,7 @@ capturingStderr action = do T.readFile path loggedError :: Text -> Text -> Bool -loggedError message = any (\l -> "[ERROR " `T.isPrefixOf` l && message `T.isInfixOf` l) . T.lines +loggedError message = any (\l -> "[ERROR " `T.isInfixOf` l && message `T.isInfixOf` l) . T.lines failCancels :: IORef StubState -> IO () failCancels ref = atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "refused")}, ()) @@ -3467,7 +3478,7 @@ testHeldWaitWakesOnAPaymentThatDoesNotSettle :: IO () testHeldWaitWakesOnAPaymentThatDoesNotSettle = bounded "funded wakes a hold" $ withCheckout $ \_ env client -> do iid <- seedOpenInvoice env held <- async $ webGet client (invoicePath iid <> "?wait=open") - threadDelay 100000 + awaitWaitingCount env 1 waitingCount (weWaiters env) `shouldReturn` 1 settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated `shouldReturn` Right ISOpen diff --git a/tests/Bots/BroadcastTests.hs b/tests/Bots/BroadcastTests.hs index 9edbb3cb73..1def872096 100644 --- a/tests/Bots/BroadcastTests.hs +++ b/tests/Bots/BroadcastTests.hs @@ -14,7 +14,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (bracket) import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Core -import Simplex.Chat.Options (CoreChatOpts (..)) +import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) import Test.Hspec hiding (it) @@ -26,11 +26,11 @@ broadcastBotTests :: SpecWith TestParams broadcastBotTests = do it "should broadcast message" testBroadcastMessages -withBroadcastBot :: BroadcastBotOpts -> IO () -> IO () -withBroadcastBot opts test = +withBroadcastBot :: TestParams -> BroadcastBotOpts -> IO () -> IO () +withBroadcastBot ps opts test = bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test) where - bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts + bot = simplexChatCore (fst $ testPortsCfg ps testCfg testOpts) (mkChatOpts opts) $ broadcastBot opts broadcastBotProfile :: Profile broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} @@ -39,11 +39,11 @@ mkBotOpts :: TestParams -> [KnownContact] -> BroadcastBotOpts mkBotOpts ps publishers = BroadcastBotOpts { coreOptions = - testCoreOpts + coreOpts { dbOptions = (dbOptions testCoreOpts) #if defined(dbPostgres) - {dbSchemaPrefix = "client_" <> botDbPrefix} + {dbSchemaPrefix = testSchemaPrefix ps botDbPrefix} #else {dbFilePrefix = tmpPath ps botDbPrefix} #endif @@ -54,6 +54,8 @@ mkBotOpts ps publishers = welcomeMessage = defaultWelcomeMessage publishers, prohibitedMessage = defaultWelcomeMessage publishers } + where + (_, ChatOpts {coreOptions = coreOpts}) = testPortsCfg ps testCfg testOpts botDbPrefix :: FilePath botDbPrefix = "broadcast_bot" @@ -67,7 +69,7 @@ testBroadcastMessages ps = do bc_bot ##> "/ad" getContactLink bc_bot True let botOpts = mkBotOpts ps [KnownContact 2 "alice"] - withBroadcastBot botOpts $ + withBroadcastBot ps botOpts $ withTestChat ps "alice" $ \alice -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 74688e9b4f..22d73f72ea 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -10,7 +10,9 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Groups (memberJoinChannel, prepareChannel1Relay) import ChatTests.Utils -import Control.Concurrent (forkIO, killThread, threadDelay) +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 qualified Data.Aeson as J @@ -21,17 +23,19 @@ import Directory.Options import Directory.Service import System.Directory (emptyPermissions, setOwnerExecutable, setOwnerReadable, setOwnerWritable, setPermissions) import Simplex.Chat.Bot.KnownContacts -import Simplex.Chat.Controller (ChatConfig (..)) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (smpAgent)) import qualified Simplex.Chat.Markdown as MD -import Simplex.Chat.Options (CoreChatOpts (..)) +import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.Protocol (memberSupportVoiceVersion) import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Messaging.Agent (disposeAgentClient) import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..)) import Simplex.Messaging.Version import NameResolver import System.FilePath (()) +import System.Timeout (timeout) import Test.Hspec hiding (it) directoryServiceTests :: SpecWith TestParams @@ -113,16 +117,16 @@ directoryProfile :: Profile directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts -mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = +mkDirectoryOpts ps superUsers ownersGroup webFolder = DirectoryOpts { coreOptions = - testCoreOpts + coreOpts { dbOptions = (dbOptions testCoreOpts) #if defined(dbPostgres) - {dbSchemaPrefix = "client_" <> serviceDbPrefix} + {dbSchemaPrefix = testSchemaPrefix ps serviceDbPrefix} #else - {dbFilePrefix = ps serviceDbPrefix} + {dbFilePrefix = tmpPath ps serviceDbPrefix} #endif }, @@ -149,6 +153,8 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = knocking = False, testing = True } + where + (_, ChatOpts {coreOptions = coreOpts}) = testPortsCfg ps testCfg testOpts serviceDbPrefix :: FilePath serviceDbPrefix = "directory_service" @@ -175,16 +181,18 @@ testDirectoryService ps = bob ##> "/mr PSA 'SimpleX Directory' admin" -- putStrLn "*** discover service joins group and sends the registration for approval" bob <## "#PSA: you changed the role of 'SimpleX Directory' to admin" - bob <# "'SimpleX Directory'> Joining the group PSA…" - bob <## "#PSA: 'SimpleX Directory' joined the group" + bob + <### [ WithTime "'SimpleX Directory'> Joining the group PSA…", + "#PSA: 'SimpleX Directory' joined the group" + ] bob <# "'SimpleX Directory'> Joined the group PSA. Registration is pending approval — it may take up to 48 hours." bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." bob <## "Captcha verification is enabled. Use /'filter 1' to change it." notifySuperUser_ superUser bob "PSA" "Privacy, Security & Anonymity" Nothing 1 1 -- putStrLn "*** update profile before approval - new approval code" updateGroupProfile bob "Welcome!" - groupUpdatedHidden superUser bob "PSA" "" - notifySuperUser_ superUser bob "PSA" "Privacy, Security & Anonymity" (Just "Welcome!") 1 2 + groupUpdatedHidden superUser bob "PSA" "" $ + notifySuperUser_ superUser bob "PSA" "Privacy, Security & Anonymity" (Just "Welcome!") 1 2 -- putStrLn "*** try approving with the old registration code" bob #> "@'SimpleX Directory' /approve 1:PSA 1" bob <# "'SimpleX Directory'> > /approve 1:PSA 1" @@ -470,8 +478,8 @@ testSearchByLink ps = memberGroupListing superUser bob 1 "privacy" "Privacy" 2 "active" -- content change hides the group from user search, admin still finds it by link setWelcomeMessage bob [] "Welcome!" - groupUpdatedHidden superUser bob "privacy" "" - notifySuperUser_ superUser bob "privacy" "Privacy" (Just "Welcome!") 1 1 + groupUpdatedHidden superUser bob "privacy" "" $ + notifySuperUser_ superUser bob "privacy" "Privacy" (Just "Welcome!") 1 1 bob #> ("@'SimpleX Directory' " <> link) bob <# ("'SimpleX Directory'> > " <> link) bob <## " No groups found." @@ -624,9 +632,11 @@ testInviteOwnerAfterLeavingOwnersGroup ps = superUser <## "#owners: new member bob is connected" -- owner leaves owners' group; GroupMember row keeps status GSMemLeft leaveGroup "owners" bob - superUser <## "#owners: bob left the group (signed)" -- owners' group has no GroupReg, so directory service notifies admins on contact left - superUser <# "'SimpleX Directory'> Error: contact left, group: 1 owners, group registration not found" + superUser + <### [ "#owners: bob left the group (signed)", + WithTime "'SimpleX Directory'> Error: contact left, group: 1 owners, group registration not found" + ] -- super-user re-invites via /invite — must send a fresh invitation, not "already a member" superUser #> "@'SimpleX Directory' /invite 2:privacy" superUser <# "'SimpleX Directory'> > /invite 2:privacy" @@ -648,9 +658,7 @@ testDelistedOwnerLeaves ps = bob <## "" bob <## "The group is no longer listed in the directory." superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is de-listed (group owner left)." - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupNotFound cath "privacy" testDelistedOwnerRemoved :: HasCallStack => TestParams -> IO () @@ -661,14 +669,17 @@ testDelistedOwnerRemoved ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - removeMember "privacy" cath bob - bob <# "'SimpleX Directory'> You are removed from the group ID 1 (privacy)." - bob <## "" - bob <## "The group is no longer listed in the directory." + cath ##> "/rm privacy bob" + cath <## "#privacy: you removed bob from the group (signed)" + bob + <### [ "#privacy: cath removed you from the group (signed)", + "use /d #privacy to delete the group", + WithTime "'SimpleX Directory'> You are removed from the group ID 1 (privacy).", + "", + "The group is no longer listed in the directory." + ] superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is de-listed (group owner is removed)." - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupNotFound cath "privacy" testNotDelistedMemberLeaves :: HasCallStack => TestParams -> IO () @@ -800,9 +811,7 @@ testDelistedRoleChanges ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupFoundN 3 cath "privacy" -- de-listed if service role changed bob ##> "/mr privacy 'SimpleX Directory' member" @@ -816,28 +825,34 @@ testDelistedRoleChanges ps = -- re-listed if service role changed back without profile changes cath ##> "/mr privacy 'SimpleX Directory' admin" cath <## "#privacy: you changed the role of 'SimpleX Directory' to admin (signed)" - bob <## "#privacy: cath changed the role of 'SimpleX Directory' from member to admin (signed)" - bob <# "'SimpleX Directory'> SimpleX Directory role in the group ID 1 (privacy) is changed to admin." - bob <## "" - bob <## "The group is listed in the directory again." + bob + <### [ "#privacy: cath changed the role of 'SimpleX Directory' from member to admin (signed)", + WithTime "'SimpleX Directory'> SimpleX Directory role in the group ID 1 (privacy) is changed to admin.", + "", + "The group is listed in the directory again." + ] superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is listed (SimpleX Directory role is changed to admin)." groupFoundN 3 cath "privacy" -- de-listed if owner role changed cath ##> "/mr privacy bob admin" cath <## "#privacy: you changed the role of bob to admin (signed)" - bob <## "#privacy: cath changed your role from owner to admin (signed)" - bob <# "'SimpleX Directory'> Your role in the group ID 1 (privacy) is changed to admin." - bob <## "" - bob <## "The group is no longer listed in the directory." + bob + <### [ "#privacy: cath changed your role from owner to admin (signed)", + WithTime "'SimpleX Directory'> Your role in the group ID 1 (privacy) is changed to admin.", + "", + "The group is no longer listed in the directory." + ] superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is de-listed (user role is set to admin)." groupNotFound cath "privacy" -- re-listed if owner role changed back without profile changes cath ##> "/mr privacy bob owner" cath <## "#privacy: you changed the role of bob to owner (signed)" - bob <## "#privacy: cath changed your role from admin to owner (signed)" - bob <# "'SimpleX Directory'> Your role in the group ID 1 (privacy) is changed to owner." - bob <## "" - bob <## "The group is listed in the directory again." + bob + <### [ "#privacy: cath changed your role from admin to owner (signed)", + WithTime "'SimpleX Directory'> Your role in the group ID 1 (privacy) is changed to owner.", + "", + "The group is listed in the directory again." + ] superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is listed (user role is set to owner)." groupFoundN 3 cath "privacy" @@ -849,9 +864,7 @@ testNotDelistedMemberRoleChanged ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupFoundN 3 cath "privacy" bob ##> "/mr privacy cath member" bob <## "#privacy: you changed the role of cath to member (signed)" @@ -872,7 +885,7 @@ testNotSentApprovalBadRoles ps = bob <## "#privacy: you changed the role of 'SimpleX Directory' to member (signed)" bob ##> "/gp privacy privacy Privacy!" bob <## "description changed to: Privacy!" - groupUpdatedHidden superUser bob "privacy" "" + groupUpdatedHidden superUser bob "privacy" "" $ pure () bob <# "'SimpleX Directory'> You must grant directory service admin role to register the group" bob ##> "/mr privacy 'SimpleX Directory' admin" bob <## "#privacy: you changed the role of 'SimpleX Directory' to admin (signed)" @@ -896,6 +909,7 @@ testNotApprovedBadRoles ps = notifySuperUser superUser bob "privacy" "Privacy" 1 bob ##> "/mr privacy 'SimpleX Directory' member" bob <## "#privacy: you changed the role of 'SimpleX Directory' to member (signed)" + serviceRoleIs superUser "member" let approve = "/approve 1:privacy 1" superUser #> ("@'SimpleX Directory' " <> approve) superUser <# ("'SimpleX Directory'> > " <> approve) @@ -909,6 +923,16 @@ testNotApprovedBadRoles ps = notifySuperUser superUser bob "privacy" "Privacy" 1 void $ approveRegistration superUser bob "privacy" 1 groupFound cath "privacy" + where + serviceRoleIs superUser expectedRole = go (50 :: Int) + where + go n = do + superUser #> "@'SimpleX Directory' /x /ms privacy" + superUser <# "'SimpleX Directory'> > /x /ms privacy" + l <- getTermLine superUser + superUser <## "bob (Bob): owner, host, connected" + let expected = " 'SimpleX Directory': " <> expectedRole <> ", you, connected" + if l == expected || n == 0 then l `shouldBe` expected else threadDelay 100000 >> go (n - 1) testRegOwnerChangedProfile :: HasCallStack => TestParams -> IO () testRegOwnerChangedProfile ps = @@ -924,12 +948,9 @@ testRegOwnerChangedProfile ps = bob <## "It is hidden from the directory until approved." cath <## "bob updated group #privacy: (signed)" cath <## "description changed to: Privacy and Security" - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupNotFound cath "privacy" - superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated." - reapproveGroup 3 superUser bob + reapproveGroup 3 superUser bob "" groupFoundN 3 cath "privacy" testAnotherOwnerChangedProfile :: HasCallStack => TestParams -> IO () @@ -940,18 +961,17 @@ testAnotherOwnerChangedProfile ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" cath ##> "/gp privacy privacy Privacy and Security" cath <## "description changed to: Privacy and Security" - bob <## "cath updated group #privacy: (signed)" - bob <## "description changed to: Privacy and Security" - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath!" - bob <## "It is hidden from the directory until approved." + bob + <### [ "cath updated group #privacy: (signed)", + "description changed to: Privacy and Security", + WithTime "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath!", + "It is hidden from the directory until approved." + ] groupNotFound cath "privacy" - superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath." - reapproveGroup 3 superUser bob + reapproveGroup 3 superUser bob " by cath" groupFoundN 3 cath "privacy" testNotConnectedOwnerChangedProfile :: HasCallStack => TestParams -> IO () @@ -966,13 +986,14 @@ testNotConnectedOwnerChangedProfile ps = addCathAsOwner bob cath cath ##> "/gp privacy privacy Privacy and Security" cath <## "description changed to: Privacy and Security" - bob <## "cath updated group #privacy: (signed)" - bob <## "description changed to: Privacy and Security" - bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath!" - bob <## "It is hidden from the directory until approved." + bob + <### [ "cath updated group #privacy: (signed)", + "description changed to: Privacy and Security", + WithTime "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath!", + "It is hidden from the directory until approved." + ] groupNotFound dan "privacy" - superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath." - reapproveGroup 3 superUser bob + reapproveGroup 3 superUser bob " by cath" groupFoundN 3 dan "privacy" testRegOwnerRemovedLink :: HasCallStack => TestParams -> IO () @@ -985,8 +1006,8 @@ testRegOwnerRemovedLink ps = addCathAsOwner bob cath -- setting the welcome message requires re-approval setWelcomeMessage bob [cath] "Welcome!" - groupUpdatedHidden superUser bob "privacy" "" - reapproveGroup_ 3 superUser bob (Just "Welcome!") + groupUpdatedHidden superUser bob "privacy" "" $ reapprovalRequested 3 superUser (Just "Welcome!") + void $ approveRegistration_ superUser bob "privacy" 1 1 1 -- adding the link keeps the group listed gLink <- getGroupLinkFromBot bob setWelcomeMessage bob [cath] ("Welcome! Link to join the group privacy: " <> gLink) @@ -994,9 +1015,7 @@ testRegOwnerRemovedLink ps = -- removing the link keeps the group listed setWelcomeMessage bob [cath] "Welcome!" groupUpdatedListed superUser bob "privacy" "" - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" groupFoundWelcome 3 cath "privacy" "Welcome!" testAnotherOwnerRemovedLink :: HasCallStack => TestParams -> IO () @@ -1007,20 +1026,20 @@ testAnotherOwnerRemovedLink ps = bob `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath - cath `connectVia` dsLink - cath <## "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" - cath <## "use @'SimpleX Directory' to send messages" + connectViaMerged cath dsLink "contact and member are merged: 'SimpleX Directory_1', #privacy 'SimpleX Directory'" -- setting the welcome message requires re-approval - setWelcomeMessage cath [bob] "Welcome!" - groupUpdatedHidden superUser bob "privacy" " by cath" - reapproveGroup_ 3 superUser bob (Just "Welcome!") + welcomeUpdatedBy bob cath "Welcome!" "It is hidden from the directory until approved." + noticeAndRequest superUser "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath." $ reapprovalRequested 3 superUser (Just "Welcome!") + void $ approveRegistration_ superUser bob "privacy" 1 1 1 -- another owner adds the link - the group remains listed gLink <- getGroupLinkFromBot bob - setWelcomeMessage cath [bob] ("Welcome! Link to join the group privacy: " <> gLink) - groupUpdatedListed superUser bob "privacy" " by cath" + welcomeUpdatedBy bob cath ("Welcome! Link to join the group privacy: " <> gLink) "The group is listed in directory." + superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath - only link or whitespace changes." + superUser <## "The group remained listed in directory." -- another owner removes the link - the group remains listed - setWelcomeMessage cath [bob] "Welcome!" - groupUpdatedListed superUser bob "privacy" " by cath" + welcomeUpdatedBy bob cath "Welcome!" "The group is listed in directory." + superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath - only link or whitespace changes." + superUser <## "The group remained listed in directory." groupFoundWelcome 3 cath "privacy" "Welcome!" testNotConnectedOwnerRemovedLink :: HasCallStack => TestParams -> IO () @@ -1034,17 +1053,19 @@ testNotConnectedOwnerRemovedLink ps = registerGroup superUser bob "privacy" "Privacy" addCathAsOwner bob cath -- setting the welcome message requires re-approval - setWelcomeMessage cath [bob] "Welcome!" - groupUpdatedHidden superUser bob "privacy" " by cath" + welcomeUpdatedBy bob cath "Welcome!" "It is hidden from the directory until approved." + noticeAndRequest superUser "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath." $ reapprovalRequested 3 superUser (Just "Welcome!") groupNotFound dan "privacy" - reapproveGroup_ 3 superUser bob (Just "Welcome!") + void $ approveRegistration_ superUser bob "privacy" 1 1 1 -- the not connected owner adds the link - the group remains listed gLink <- getGroupLinkFromBot bob - setWelcomeMessage cath [bob] ("Welcome! Link to join the group privacy: " <> gLink) - groupUpdatedListed superUser bob "privacy" " by cath" + welcomeUpdatedBy bob cath ("Welcome! Link to join the group privacy: " <> gLink) "The group is listed in directory." + superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath - only link or whitespace changes." + superUser <## "The group remained listed in directory." -- the not connected owner removes the link - the group remains listed - setWelcomeMessage cath [bob] "Welcome!" - groupUpdatedListed superUser bob "privacy" " by cath" + welcomeUpdatedBy bob cath "Welcome!" "The group is listed in directory." + superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated by cath - only link or whitespace changes." + superUser <## "The group remained listed in directory." groupFoundWelcome 3 dan "privacy" "Welcome!" testDuplicateAskConfirmation :: HasCallStack => TestParams -> IO () @@ -1123,8 +1144,8 @@ testDuplicateProhibitWhenUpdated ps = cath <## "changed to #security (Security)" cath <# "'SimpleX Directory'> The group ID 1 (security) is updated!" cath <## "It is hidden from the directory until approved." - superUser <# "'SimpleX Directory'> The group ID 2 (security) is updated." - notifySuperUser_ superUser cath "security" "Security" Nothing 2 2 + noticeAndRequest superUser "'SimpleX Directory'> The group ID 2 (security) is updated." $ + notifySuperUser_ superUser cath "security" "Security" Nothing 2 2 void $ approveRegistration_ superUser cath "security" 2 1 2 groupFound bob "security" groupFound cath "security" @@ -1157,13 +1178,13 @@ testDuplicateProhibitApproval ps = testListUserGroups :: HasCallStack => Bool -> TestParams -> IO () testListUserGroups promote ps = - withDirectoryServiceCfgOwnersGroup ps testCfg False (Just "./tests/tmp/web") $ \superUser dsLink -> + withDirectoryServiceCfgOwnersGroup ps testCfg False (Just webDir) $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink cath `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" - checkListings ["privacy"] [] + checkListings webDir ["privacy"] [] connectUsers bob cath fullAddMember "privacy" "Privacy" bob cath GRMember joinGroup "privacy" cath bob @@ -1171,9 +1192,9 @@ testListUserGroups promote ps = cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'" cath <## "use @'SimpleX Directory' to send messages" registerGroupId superUser bob "security" "Security" 2 2 - checkListings ["privacy", "security"] [] + checkListings webDir ["privacy", "security"] [] registerGroupId superUser cath "anonymity" "Anonymity" 3 1 - checkListings ["privacy", "security", "anonymity"] [] + checkListings webDir ["privacy", "security", "anonymity"] [] listUserGroup cath "anonymity" "Anonymity" -- with de-listed group groupFound cath "anonymity" @@ -1183,41 +1204,39 @@ testListUserGroups promote ps = cath <## "" cath <## "The group is no longer listed in the directory." superUser <# "'SimpleX Directory'> The group ID 3 (anonymity) is de-listed (SimpleX Directory role is changed to member)." - checkListings ["privacy", "security"] [] + checkListings webDir ["privacy", "security"] [] groupNotFound cath "anonymity" listGroups superUser bob cath when promote $ do superUser #> "@'SimpleX Directory' /promote 1:privacy on" superUser <# "'SimpleX Directory'> > /promote 1:privacy on" superUser <## " Group promotion enabled." - checkListings ["privacy", "security"] ["privacy"] + checkListings webDir ["privacy", "security"] ["privacy"] bob ##> "/gp privacy privacy" bob <## "description removed" cath <## "bob updated group #privacy: (signed)" cath <## "description removed" - groupUpdatedHidden superUser bob "privacy" "" - superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" - superUser <## "privacy" - superUser <## "3 members" - superUser <## "" - superUser <## "To approve send:" - superUser <# "'SimpleX Directory'> /approve 1:privacy 1 promote=on" - checkListings ["security"] [] + groupUpdatedHidden superUser bob "privacy" "" $ do + superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" + superUser <## "privacy" + superUser <## "3 members" + superUser <## "" + superUser <## "To approve send:" + superUser <# "'SimpleX Directory'> /approve 1:privacy 1 promote=on" + checkListings webDir ["security"] [] superUser #> "@'SimpleX Directory' /approve 1:privacy 1" superUser <# "'SimpleX Directory'> > /approve 1:privacy 1" superUser <## " Group approved (promoted)!" void $ groupApprovedNotification bob "privacy" 1 - checkListings ["privacy", "security"] ["privacy"] - -checkListings :: HasCallStack => [T.Text] -> [T.Text] -> IO () -checkListings listed promoted = do - threadDelay 100000 - checkListing listingFileName listed - checkListing promotedFileName promoted + checkListings webDir ["privacy", "security"] ["privacy"] where - checkListing f expected = do - Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web/data" f - map groupName gs `shouldBe` expected + webDir = tmpFile ps "web" + +checkListings :: HasCallStack => FilePath -> [T.Text] -> [T.Text] -> IO () +checkListings webDir listed promoted = + ((,) <$> readListing listingFileName <*> readListing promotedFileName) `shouldEventuallyReturn` (listed, promoted) + where + readListing f = maybe [] (\(DirectoryListing gs) -> map groupName gs) <$> J.decodeFileStrict (webDir "data" f) groupName DirectoryEntry {displayName} = displayName testAlwaysCaptcha :: HasCallStack => TestParams -> IO () @@ -1648,14 +1667,14 @@ withDirectoryServiceOpts ps modOpts test = do ds ##> "/ad" getContactLink ds True let opts = modOpts $ mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing - runDirectory testCfg opts $ + runDirectory ps testCfg opts $ withTestChatCfg ps testCfg "super_user" $ \superUser -> do superUser <## "subscribed 1 connections on server localhost" test superUser dsLink withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO () -withDirectoryServiceVoiceCaptcha ps voiceScript = - withDirectoryServiceOpts ps (\o -> o {voiceCaptchaGenerator = Just voiceScript}) +withDirectoryServiceVoiceCaptcha ps voiceScript test = + withXFTPServer ps $ withDirectoryServiceOpts ps (\o -> o {voiceCaptchaGenerator = Just voiceScript}) test testRestoreDirectory :: HasCallStack => TestParams -> IO () testRestoreDirectory ps = do @@ -1735,11 +1754,14 @@ groupListing_ su owner_ gId n fn count status = do su <## ("Status: " <> status) su <## ("/'role " <> show gId <> "', /'filter " <> show gId <> "'") -reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> IO () -reapproveGroup count superUser bob = reapproveGroup_ count superUser bob Nothing +reapproveGroup :: HasCallStack => Int -> TestCC -> TestCC -> String -> IO () +reapproveGroup count superUser bob byMember = do + noticeAndRequest superUser ("'SimpleX Directory'> The group ID 1 (privacy) is updated" <> byMember <> ".") $ + reapprovalRequested count superUser Nothing + void $ approveRegistration_ superUser bob "privacy" 1 1 1 -reapproveGroup_ :: HasCallStack => Int -> TestCC -> TestCC -> Maybe String -> IO () -reapproveGroup_ count superUser bob welcome_ = do +reapprovalRequested :: HasCallStack => Int -> TestCC -> Maybe String -> IO () +reapprovalRequested count superUser welcome_ = do superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" superUser <##. "privacy (" forM_ welcome_ $ \welcome -> do @@ -1749,10 +1771,6 @@ reapproveGroup_ count superUser bob welcome_ = do superUser <## "" superUser <## "To approve send:" superUser <# "'SimpleX Directory'> /approve 1:privacy 1" - superUser #> "@'SimpleX Directory' /approve 1:privacy 1" - superUser <# "'SimpleX Directory'> > /approve 1:privacy 1" - superUser <## " Group approved!" - void $ groupApprovedNotification bob "privacy" 1 addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO () addCathAsOwner bob cath = do @@ -1806,18 +1824,19 @@ withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False Nothi withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] (if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing) webFolder - runDirectory cfg opts $ + runDirectory ps cfg opts $ withTestChatCfg ps cfg "super_user" $ \superUser -> do if createOwnersGroup then superUser <## "subscribed 2 connections on server localhost" else superUser <## "subscribed 1 connections on server localhost" test superUser dsLink -runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO () -runDirectory cfg opts action = do - t <- forkIO $ directoryService opts cfg +runDirectory :: TestParams -> ChatConfig -> DirectoryOpts -> IO () -> IO () +runDirectory ps cfg opts action = do + env <- newServiceState opts + t <- async $ directoryService opts (fst $ testPortsCfg ps cfg testOpts) env threadDelay 500000 - action `finally` killThread t + action `finally` (cancel t >> atomically (tryReadTMVar $ serviceCC env) >>= mapM_ (disposeAgentClient . smpAgent)) registerGroup :: TestCC -> TestCC -> String -> String -> IO () registerGroup su u n fn = registerGroupId su u n fn 1 1 @@ -1846,6 +1865,21 @@ groupAccepted u n ugId = do u <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." u <## ("Captcha verification is enabled. Use /'filter " <> show ugId <> "' to change it.") +channelJoinedByDirectory :: HasCallStack => TestCC -> TestCC -> IO () +channelJoinedByDirectory owner relay = + concurrentlyN_ + [ do + relay <## "'SimpleX Directory': accepting request to join group #news..." + relay <## "#news: 'SimpleX Directory' joined the group", + owner + <### [ WithTime "'SimpleX Directory'> Joining the channel news…", + "#news: relay introduced 'SimpleX Directory_1' in the channel", + WithTime "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours.", + WithTime "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them.", + "Captcha verification is enabled. Use /'filter 1' to change it." + ] + ] + completeRegistration :: TestCC -> TestCC -> String -> String -> Int -> IO String completeRegistration su u n fn gId = completeRegistrationId su u n fn gId gId @@ -1898,11 +1932,22 @@ groupApprovedNotification u n ugId = do u <## ("/'link " <> show ugId <> "' - to view group link.") dropStrPrefix "'SimpleX Directory'> " . dropTime <$> getTermLine u -groupUpdatedHidden :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () -groupUpdatedHidden superUser u n byMember = do +groupUpdatedHidden :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () -> IO () +groupUpdatedHidden superUser u n byMember approvalRequest = do u <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> "!") u <## "It is hidden from the directory until approved." - superUser <# ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> ".") + noticeAndRequest superUser ("'SimpleX Directory'> The group ID 1 (" <> n <> ") is updated" <> byMember <> ".") approvalRequest + +noticeAndRequest :: HasCallStack => TestCC -> String -> IO () -> IO () +noticeAndRequest su notice request = do + noticeFirst <- (notice ==) . dropTime <$> peekTermLine su + if noticeFirst + then su <# notice >> request + else request >> su <# notice + +peekTermLine :: HasCallStack => TestCC -> IO String +peekTermLine cc = + 20000000 `timeout` atomically (peekTQueue $ termQ cc) >>= maybe (error "no output for 20 seconds") pure groupUpdatedListed :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () groupUpdatedListed superUser u n byMember = do @@ -1922,6 +1967,18 @@ setWelcomeMessage u others welcome = do m <## "welcome message changed to:" m <## welcome +welcomeUpdatedBy :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () +welcomeUpdatedBy owner updater welcome status = do + uName <- userName updater + setWelcomeMessage updater [] welcome + owner + <### [ ConsoleString (uName <> " updated group #privacy: (signed)"), + "welcome message changed to:", + ConsoleString welcome, + WithTime ("'SimpleX Directory'> The group ID 1 (privacy) is updated by " <> uName <> "!"), + ConsoleString status + ] + connectVia :: TestCC -> String -> IO () u `connectVia` dsLink = do u ##> ("/c " <> dsLink) @@ -1935,6 +1992,23 @@ u `connectVia` dsLink = do u <## "" u <## "[Directory rules](https://simplex.chat/docs/directory.html)." +connectViaMerged :: HasCallStack => TestCC -> String -> String -> IO () +connectViaMerged u dsLink merged = do + u ##> ("/c " <> dsLink) + u <## "connection request sent!" + u .<## ": contact is connected" + u + <### [ EndsWith "> Welcome to SimpleX Directory!", + "", + "🔍 Send search string to find groups - try security.", + "/help - how to submit your group or channel.", + "/new - recent groups.", + "", + "[Directory rules](https://simplex.chat/docs/directory.html).", + ConsoleString merged, + "use @'SimpleX Directory' to send messages" + ] + joinGroup :: String -> TestCC -> TestCC -> IO () joinGroup gName member host = do let gn = "#" <> gName @@ -2040,11 +2114,12 @@ testCaptchaTooManyAttempts ps = pure () cath #> "#privacy (support) wrong" cath <# "#privacy (support) 'SimpleX Directory'> Too many failed attempts, you can't join group." - -- member removal produces multiple messages - _ <- getTermLine cath - _ <- getTermLine cath - _ <- getTermLine cath - pure () + let removed = "#privacy: 'SimpleX Directory' removed you from the group (signed)" + line <- getTermLine cath + when (line /= removed) $ do + line `shouldContain` "error: connection authorization failed" + cath <## removed + cath <## "use /d #privacy to delete the group" testCaptchaUnknownCommand :: HasCallStack => TestParams -> IO () testCaptchaUnknownCommand ps = @@ -2113,17 +2188,7 @@ testRegisterChannelViaCard ps = _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON -- directory bot validates and joins via relay - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - -- owner sends a message to trigger member introduction - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2146,15 +2211,15 @@ testRegisterChannelViaCard ps = bob <## "It is hidden from the directory until approved." relay <## "bob updated group #news: (signed)" relay <## "description changed to: News and Updates" - superUser <# "'SimpleX Directory'> The channel ID 1 (news) is updated." - superUser <# ("'SimpleX Directory'> bob submitted the channel ID 1:") - superUser <## "news (News and Updates)" - superUser <##. "Link to join channel: " - superUser <## "You need SimpleX Chat app v6.5 to join." - superUser <## "2 subscribers" - superUser <## "" - superUser <## "To approve send:" - superUser <# "'SimpleX Directory'> /approve 1:news 1" + noticeAndRequest superUser "'SimpleX Directory'> The channel ID 1 (news) is updated." $ do + superUser <# ("'SimpleX Directory'> bob submitted the channel ID 1:") + superUser <## "news (News and Updates)" + superUser <##. "Link to join channel: " + superUser <## "You need SimpleX Chat app v6.5 to join." + superUser <## "2 subscribers" + superUser <## "" + superUser <## "To approve send:" + superUser <# "'SimpleX Directory'> /approve 1:news 1" -- re-approve after profile update let approve2 = "/approve 1:news 1" superUser #> ("@'SimpleX Directory' " <> approve2) @@ -2178,7 +2243,7 @@ testRegisterChannelViaCard ps = -- owner sets a name; directory verifies name<->link consistency and shows the verified name to the admin testDirectoryChannelName :: HasCallStack => TestParams -> IO () -testDirectoryChannelName ps = withSmpServerAndNames $ \reg -> +testDirectoryChannelName ps = withSmpServerAndNames ps $ \reg -> withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do @@ -2194,16 +2259,7 @@ testDirectoryChannelName ps = withSmpServerAndNames $ \reg -> bob <# "@'SimpleX Directory' link to join channel #news (signed):" _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay -- the directory verified the name against the channel link and shows it to the admin superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" @@ -2219,7 +2275,7 @@ testDirectoryChannelName ps = withSmpServerAndNames $ \reg -> -- registry re-pointed to a different link after the owner set the name: directory verification fails testDirectoryChannelNameNotVerified :: HasCallStack => TestParams -> IO () -testDirectoryChannelNameNotVerified ps = withSmpServerAndNames $ \reg -> +testDirectoryChannelNameNotVerified ps = withSmpServerAndNames ps $ \reg -> withDirectoryServiceCfg ps testCfg $ \superUser dsLink -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> withRelay ps $ \relay -> do @@ -2237,16 +2293,7 @@ testDirectoryChannelNameNotVerified ps = withSmpServerAndNames $ \reg -> bob <# "@'SimpleX Directory' link to join channel #news (signed):" _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <## "SimpleX name: #news (NOT verified - will not be shown)" @@ -2297,16 +2344,7 @@ testDeleteChannelRegistration ps = bob <# "@'SimpleX Directory' link to join channel #news (signed):" _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2343,16 +2381,7 @@ testReregistrationAlreadyListed ps = bob <# "@'SimpleX Directory' link to join channel #news (signed):" _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2391,7 +2420,7 @@ testLinkCheckUpdatesCount ps = do ds ##> "/ad" getContactLink ds True let opts = (mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing) {linkCheckInterval = 1} - runDirectory testCfg opts $ + runDirectory ps testCfg opts $ withTestChatCfg ps testCfg "super_user" $ \superUser -> do superUser <## "subscribed 1 connections on server localhost" withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> @@ -2404,16 +2433,7 @@ testLinkCheckUpdatesCount ps = do bob <# "@'SimpleX Directory' link to join channel #news (signed):" _ <- getTermLine bob -- short link _ <- getTermLine bob -- ownerSig JSON - bob <# "'SimpleX Directory'> Joining the channel news…" - concurrentlyN_ - [ do - relay <## "'SimpleX Directory': accepting request to join group #news..." - relay <## "#news: 'SimpleX Directory' joined the group", - bob <## "#news: relay introduced 'SimpleX Directory_1' in the channel" - ] - bob <# "'SimpleX Directory'> Joined the channel news. Registration is pending approval — it may take up to 48 hours." - bob <# "'SimpleX Directory'> We recommend allowing direct messages, media, voice, and SimpleX links only for group moderators and admins. Use group preferences to set them." - bob <## "Captcha verification is enabled. Use /'filter 1' to change it." + channelJoinedByDirectory bob relay superUser <# "'SimpleX Directory'> bob submitted the channel ID 1:" superUser <## "news" superUser <##. "Link to join channel: " @@ -2429,25 +2449,24 @@ testLinkCheckUpdatesCount ps = do bob <# ("'SimpleX Directory'> The channel ID 1 (news) is approved and listed in directory - please moderate it!") bob <## "Please note: if you change the channel profile it will be hidden from directory until it is re-approved." -- link check updates count (bot joined) - threadDelay 1000000 - bob #> "@'SimpleX Directory' news" - bob <# "'SimpleX Directory'> > news" - bob <## " Found 1 group(s)." - bob <# "'SimpleX Directory'> news" - bob <##. "Link to join channel: " - bob <## "You need SimpleX Chat app v6.5 to join." - bob <## "2 subscribers" + searchSubscribers bob "2 subscribers" -- second subscriber joins memberJoinChannel "news" [relay] [bob] shortLink fullLink cath -- link check updates count again - threadDelay 1000000 - bob #> "@'SimpleX Directory' news" - bob <# "'SimpleX Directory'> > news" - bob <## " Found 1 group(s)." - bob <# "'SimpleX Directory'> news" - bob <##. "Link to join channel: " - bob <## "You need SimpleX Chat app v6.5 to join." - bob <## "3 subscribers" + searchSubscribers bob "3 subscribers" + where + searchSubscribers bob expected = go (20 :: Int) + where + go n = do + threadDelay 500000 + bob #> "@'SimpleX Directory' news" + bob <# "'SimpleX Directory'> > news" + bob <## " Found 1 group(s)." + bob <# "'SimpleX Directory'> news" + bob <##. "Link to join channel: " + bob <## "You need SimpleX Chat app v6.5 to join." + countLine <- getTermLine bob + if countLine == expected || n == 0 then countLine `shouldBe` expected else go (n - 1) testGetCaptchaStr :: HasCallStack => TestParams -> IO () testGetCaptchaStr _ps = do diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index d321e37b72..fa6d0f37d3 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -58,7 +58,7 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConf import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Client (ProtocolClientConfig (..)) import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) -import Simplex.Messaging.Protocol (ProtocolType (..)) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..)) import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM (ServerConfig (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..), defaultMessageExpiration, defaultIdleQueueInterval, defaultNtfExpiration, defaultInactiveClientExpiration) import NameResolver (NameRegistry, resolverNamesConfig, withNameResolver) @@ -67,7 +67,7 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal -import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) +import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly) import System.FilePath (()) import qualified System.Terminal as C import System.Terminal.Internal (Command (..), Terminal (..), VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal) @@ -75,8 +75,11 @@ import System.Timeout (timeout) import Test.Hspec (Expectation, HasCallStack, shouldReturn) #if defined(dbPostgres) import qualified Data.ByteString.Char8 as B +import Data.String (fromString) import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +import qualified Database.PostgreSQL.Simple as PSQL import Simplex.Messaging.Agent.Store.Interface (DBOpts (..)) +import System.FilePath (takeFileName) #else import Data.ByteArray (ScrubbedBytes) import qualified Data.Map.Strict as M @@ -105,8 +108,68 @@ testDBConnectInfo = } #endif -serverPort :: ServiceName -serverPort = "7001" +class HasTestParams a where + testParams :: a -> TestParams + +instance HasTestParams TestParams where + testParams = id + +instance HasTestParams TestCC where + testParams TestCC {ccParams} = ccParams + +tmpDir :: HasTestParams a => a -> FilePath +tmpDir = tmpPath . testParams + +tmpFile :: HasTestParams a => a -> FilePath -> FilePath +tmpFile p f = tmpDir p f + +testPort :: HasTestParams a => Int -> a -> ServiceName +testPort offset p = show $ portBase (testParams p) + offset + +smpTestPort :: HasTestParams a => a -> ServiceName +smpTestPort = testPort 1 + +xftpTestPort :: HasTestParams a => a -> ServiceName +xftpTestPort = testPort 2 + +smpTestPort2 :: HasTestParams a => a -> ServiceName +smpTestPort2 = testPort 3 + +remoteTestPort :: HasTestParams a => a -> ServiceName +remoteTestPort = testPort 4 + +testServerKeyHash :: String +testServerKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" + +smpServerStr :: HasTestParams a => a -> String +smpServerStr p = "smp://" <> testServerKeyHash <> ":server_password@localhost:" <> smpTestPort p + +smpServer2Str :: HasTestParams a => a -> String +smpServer2Str p = "smp://" <> testServerKeyHash <> ":server_password@localhost:" <> smpTestPort2 p + +xftpServerStr :: HasTestParams a => a -> String +xftpServerStr p = "xftp://" <> testServerKeyHash <> ":server_password@localhost:" <> xftpTestPort p + +mapTestPort :: TestParams -> ServiceName -> ServiceName +mapTestPort ps = \case + "7001" -> smpTestPort ps + "7002" -> xftpTestPort ps + "7003" -> smpTestPort2 ps + port -> port + +mapServerPort :: (ServiceName -> ServiceName) -> ProtocolServer p -> ProtocolServer p +mapServerPort f srv@ProtocolServer {port} = srv {port = f port} + +mapServerAuthPort :: (ServiceName -> ServiceName) -> ProtoServerWithAuth p -> ProtoServerWithAuth p +mapServerAuthPort f (ProtoServerWithAuth srv auth) = ProtoServerWithAuth (mapServerPort f srv) auth + +testPortsCfg :: TestParams -> ChatConfig -> ChatOpts -> (ChatConfig, ChatOpts) +testPortsCfg ps cfg@ChatConfig {shortLinkPresetServers} opts@ChatOpts {coreOptions = co@CoreChatOpts {smpServers, xftpServers}} = + ( cfg {shortLinkPresetServers = L.map (mapServerPort f) shortLinkPresetServers}, + opts {coreOptions = co {smpServers = map (mapServerAuthPort f) smpServers, xftpServers = map (mapServerAuthPort f) xftpServers}} + ) + where + f = mapTestPort ps testOpts :: ChatOpts testOpts = @@ -199,7 +262,8 @@ data TestCC = TestCC { chatController :: ChatController, chatAsync :: Async (), termQ :: TQueue String, - printOutput :: Bool + printOutput :: Bool, + ccParams :: TestParams } data TestTerminal = TestTerminal VirtualTerminal (TQueue String) @@ -310,8 +374,17 @@ startTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix = do createDatabase :: TestParams -> CoreChatOpts -> String -> IO (Either MigrationError ChatDatabase) #if defined(dbPostgres) -createDatabase _params CoreChatOpts {dbOptions} dbPrefix = do - createChatDatabase dbOptions {dbSchemaPrefix = "client_" <> dbPrefix} (MigrationConfig MCError Nothing) +createDatabase ps CoreChatOpts {dbOptions} dbPrefix = do + createChatDatabase dbOptions {dbSchemaPrefix = testSchemaPrefix ps dbPrefix} (MigrationConfig MCError Nothing) + +testSchemaPrefix :: HasTestParams a => a -> String -> String +testSchemaPrefix p dbPrefix = "client_" <> takeFileName (tmpDir p) <> "_" <> dbPrefix + +dropTestSchemas :: HasTestParams a => a -> IO () +dropTestSchemas p = + bracket (PSQL.connect testDBConnectInfo) PSQL.close $ \db -> do + schemas <- PSQL.query db "SELECT schema_name FROM information_schema.schemata WHERE schema_name LIKE ?" (PSQL.Only $ testSchemaPrefix p "%") + forM_ schemas $ \(PSQL.Only schema) -> PSQL.execute_ db $ fromString $ "DROP SCHEMA " <> (schema :: String) <> " CASCADE" insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") @@ -324,7 +397,8 @@ insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) V #endif startTestChat_ :: TestParams -> ChatDatabase -> ChatConfig -> ChatOpts -> String -> User -> IO TestCC -startTestChat_ TestParams {tmpPath, printOutput} db cfg opts@ChatOpts {coreOptions = CoreChatOpts {maintenance}} dbPrefix user = do +startTestChat_ ps@TestParams {tmpPath, printOutput} db cfg_ opts_ dbPrefix user = do + let (cfg, opts@ChatOpts {coreOptions = CoreChatOpts {maintenance}}) = testPortsCfg ps cfg_ opts_ termQ <- newTQueueIO t <- withVirtualTerminal termSettings $ pure . (`TestTerminal` termQ) ct <- newChatTerminal t opts @@ -332,7 +406,7 @@ startTestChat_ TestParams {tmpPath, printOutput} db cfg opts@ChatOpts {coreOptio 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 - pure TestCC {chatController = cc, chatAsync, termQ, printOutput} + pure TestCC {chatController = cc, chatAsync, termQ, printOutput, ccParams = ps} stopTestChat :: TestParams -> TestCC -> IO () stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}, chatAsync} = do @@ -433,8 +507,20 @@ enableNamesRole TestCC {chatController = cc} = do withTmpFiles :: IO () -> IO () withTmpFiles = bracket_ - (createDirectoryIfMissing False "tests/tmp") - (removeDirectoryRecursive "tests/tmp") + (createDirectoryIfMissing False "tests/tmp" >> clearTmp) + clearTmp + where + clearTmp = listDirectory "tests/tmp" >>= mapM_ (removePathForcibly . ("tests/tmp" )) + +newPortBases :: IO (TVar [Int]) +newPortBases = newTVarIO [7000, 7010 .. 8990] + +withPortBase :: TVar [Int] -> (Int -> IO a) -> IO a +withPortBase bases = bracket takeBase (\b -> atomically $ modifyTVar' bases (b :)) + where + takeBase = atomically $ readTVar bases >>= \case + b : bs -> writeTVar bases bs $> b + [] -> retry testChatN :: HasCallStack => ChatConfig -> ChatOpts -> [Profile] -> (HasCallStack => [TestCC] -> IO ()) -> TestParams -> IO () testChatN cfg opts ps test params = @@ -456,7 +542,7 @@ getTermLine = getTermLine' Nothing getTermLine' :: HasCallStack => Maybe String -> TestCC -> IO String getTermLine' expected cc@TestCC {printOutput} = - 5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case + 20000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case Just s -> do -- remove condition to always echo virtual terminal -- when True $ do @@ -469,7 +555,7 @@ getTermLine' expected cc@TestCC {printOutput} = let expectedMsg = case expected of Just e -> ", expected: " <> show e Nothing -> "" - error $ name <> ": no output for 5 seconds" <> expectedMsg + error $ name <> ": no output for 20 seconds" <> expectedMsg userName :: TestCC -> IO [Char] userName TestCC {chatController = ChatController {currentUser}} = @@ -546,10 +632,10 @@ testChatCfg5 cfg p1 p2 p3 p4 p5 test = testChatN cfg testOpts [p1, p2, p3, p4, p concurrentlyN_ :: [IO a] -> IO () concurrentlyN_ = mapConcurrently_ id -smpServerCfg :: ServerConfig STMMsgStore -smpServerCfg = +smpServerCfg :: HasTestParams a => a -> ServerConfig STMMsgStore +smpServerCfg p = ServerConfig - { transports = [(serverPort, transport @TLS, False)], + { transports = [(smpTestPort p, transport @TLS, False)], tbqSize = 4, msgQueueQuota = 16, maxJournalMsgCount = 24, @@ -601,33 +687,30 @@ smpServerCfg = persistentServerStoreCfg :: FilePath -> ServerStoreCfg STMMsgStore persistentServerStoreCfg tmp = SSCMemory $ Just StorePaths {storeLogFile = tmp <> "/smp-server-store.log", storeMsgsFile = Just $ tmp <> "/smp-server-messages.log"} -withSmpServer :: IO () -> IO () -withSmpServer = withSmpServer' smpServerCfg +withSmpServer :: HasTestParams a => a -> IO b -> IO b +withSmpServer p = withSmpServer' (smpServerCfg p) withSmpServer' :: ServerConfig STMMsgStore -> IO a -> IO a withSmpServer' cfg = serverBracket (\started -> runSMPServerBlocking started cfg Nothing) -- | SMP server with a local names resolver attached; the action gets the resolver -- registry to map names to the addresses it creates. -withSmpServerAndNames :: (NameRegistry -> IO a) -> IO a -withSmpServerAndNames action = +withSmpServerAndNames :: HasTestParams a => a -> (NameRegistry -> IO b) -> IO b +withSmpServerAndNames p action = withNameResolver $ \port reg -> - withSmpServer' smpServerCfg {namesConfig = Just (resolverNamesConfig port)} (action reg) + withSmpServer' (smpServerCfg p) {namesConfig = Just (resolverNamesConfig port)} (action reg) -xftpTestPort :: ServiceName -xftpTestPort = "7002" +xftpServerFiles :: HasTestParams a => a -> FilePath +xftpServerFiles p = tmpFile p "xftp-server-files" -xftpServerFiles :: FilePath -xftpServerFiles = "tests/tmp/xftp-server-files" - -xftpServerConfig :: XFTPServerConfig STMFileStore -xftpServerConfig = +xftpServerConfig :: HasTestParams a => a -> XFTPServerConfig STMFileStore +xftpServerConfig p = XFTPServerConfig - { xftpPort = xftpTestPort, + { xftpPort = xftpTestPort p, fileIdSize = 16, - serverStoreCfg = XSCMemory $ Just "tests/tmp/xftp-server-store.log", - storeLogFile = Just "tests/tmp/xftp-server-store.log", - filesPath = xftpServerFiles, + serverStoreCfg = XSCMemory $ Just storeLog, + storeLogFile = Just storeLog, + filesPath = xftpServerFiles p, fileSizeQuota = Nothing, allowedChunkSizes = [kb 64, kb 128, kb 256, mb 1, mb 4], allowNewFiles = True, @@ -651,23 +734,25 @@ xftpServerConfig = information = Nothing, logStatsInterval = Nothing, logStatsStartTime = 0, - serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", + serverStatsLogFile = tmpFile p "xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, prometheusInterval = Nothing, - prometheusMetricsFile = "tests/xftp-server-metrics.txt", + prometheusMetricsFile = tmpFile p "xftp-server-metrics.txt", controlPort = Nothing, transportConfig = mkTransportServerConfig True (Just alpnSupportedXFTPhandshakes) False, responseDelay = 0 } + where + storeLog = tmpFile p "xftp-server-store.log" -withXFTPServer :: IO () -> IO () -withXFTPServer = withXFTPServer' xftpServerConfig +withXFTPServer :: HasTestParams a => a -> IO b -> IO b +withXFTPServer p = withXFTPServer' (xftpServerConfig p) -withXFTPServer' :: XFTPServerConfig STMFileStore -> IO () -> IO () -withXFTPServer' cfg = +withXFTPServer' :: XFTPServerConfig STMFileStore -> IO a -> IO a +withXFTPServer' cfg@XFTPServerConfig {filesPath} = serverBracket ( \started -> do - createDirectoryIfMissing False xftpServerFiles + createDirectoryIfMissing False filesPath runXFTPServerBlocking started cfg ) diff --git a/tests/ChatTests/ChatRelays.hs b/tests/ChatTests/ChatRelays.hs index a555fcc9ef..baf8d10d16 100644 --- a/tests/ChatTests/ChatRelays.hs +++ b/tests/ChatTests/ChatRelays.hs @@ -548,9 +548,7 @@ testWebPreviewMultipleChannels ps = do relay <# "#ch1> msg in ch1" alice #> "#ch2 msg in ch2" relay <# "#ch2> msg in ch2" - threadDelay 2000000 - files <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir - length files `shouldBe` 2 + (length . filter (\f -> takeExtension f == ".json") <$> listDirectory webDir) `shouldEventuallyReturn` 2 testWebPreviewChannelDeleted :: HasCallStack => TestParams -> IO () testWebPreviewChannelDeleted ps = diff --git a/tests/ChatTests/DBUtils/Postgres.hs b/tests/ChatTests/DBUtils/Postgres.hs index 2b160379bb..76791c6ce8 100644 --- a/tests/ChatTests/DBUtils/Postgres.hs +++ b/tests/ChatTests/DBUtils/Postgres.hs @@ -2,5 +2,6 @@ module ChatTests.DBUtils.Postgres where data TestParams = TestParams { tmpPath :: FilePath, + portBase :: Int, printOutput :: Bool } diff --git a/tests/ChatTests/DBUtils/SQLite.hs b/tests/ChatTests/DBUtils/SQLite.hs index 2de94882cd..3c71dd8ce9 100644 --- a/tests/ChatTests/DBUtils/SQLite.hs +++ b/tests/ChatTests/DBUtils/SQLite.hs @@ -6,6 +6,7 @@ import Simplex.Messaging.TMap (TMap) data TestParams = TestParams { tmpPath :: FilePath, + portBase :: Int, printOutput :: Bool, chatQueryStats :: TMap Query SlowQueryStats, agentQueryStats :: TMap Query SlowQueryStats diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index af1b140d2f..b95d738589 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -15,7 +15,7 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Utils import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, poll) +import Control.Concurrent.Async (concurrently_, poll, wait) import Control.Monad (forM_, void, (>=>)) import Data.Aeson (ToJSON) import qualified Data.Aeson as J @@ -274,8 +274,8 @@ testRetryConnecting ps = testChatCfgOpts2 cfg' opts' aliceProfile bobProfile tes bob <## "disconnected 1 connections on server localhost" alice <## "disconnected 1 connections on server localhost" serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], msgQueueQuota = 2, serverStoreCfg = persistentServerStoreCfg tmp } @@ -309,12 +309,13 @@ testRetryConnectingClientTimeout ps = do bob <## "invitation link: ok to connect" _sLinkData <- getTermLine bob bob ##> ("/_connect 1 " <> inv) - bob <## "smp agent error: BROKER {brokerAddress = \"smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7003\", brokerErr = TIMEOUT}" + bob <## ("smp agent error: BROKER {brokerAddress = \"smp://" <> testServerKeyHash <> "@localhost:" <> smpTestPort2 ps <> "\", brokerErr = TIMEOUT}") pure inv - logFile <- readFile $ tmp <> "/smp-server-store.log" - logFile `shouldContain` "SECURE" + -- TODO enable with slow_servers SMP response delay, the client may drop SKEY before sending + -- logFile <- readFile $ tmp <> "/smp-server-store.log" + -- logFile `shouldContain` "SECURE" withSmpServer' serverCfg' $ do withTestChatCfgOpts ps cfg' opts' "alice" $ \alice -> do @@ -338,8 +339,8 @@ testRetryConnectingClientTimeout ps = do where tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], msgQueueQuota = 2, serverStoreCfg = persistentServerStoreCfg tmp } @@ -1137,9 +1138,9 @@ testGetSetSMPServers = alice ##> "/_servers 1" alice <## "Your servers" alice <## " SMP servers" - alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001" + alice <## (" " <> smpServerStr alice) alice <## " XFTP servers" - alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002" + alice <## (" " <> xftpServerStr alice) alice #$> ("/smp smp://1234-w==@smp1.example.im", id, "ok") alice ##> "/smp" alice <## "Your servers" @@ -1162,27 +1163,27 @@ testTestSMPServerConnection :: HasCallStack => TestParams -> IO () testTestSMPServerConnection = testChat aliceProfile $ \alice -> do - alice ##> "/smp test smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" + alice ##> ("/smp test smp://" <> testServerKeyHash <> "@localhost:" <> smpTestPort alice) alice <## "SMP server test passed" -- to test with password: -- alice <## "SMP server test failed at CreateQueue, error: SMP AUTH" -- alice <## "Server requires authorization to create queues, check password" - alice ##> "/smp test smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001" + alice ##> ("/smp test " <> smpServerStr alice) alice <## "SMP server test passed" - alice ##> "/smp test smp://LcJU@localhost:7001" - alice <## "SMP server test failed at Connect, error: BROKER {brokerAddress = \"smp://LcJU@localhost:7001\", brokerErr = NETWORK {networkError = NEUnknownCAError}}" + alice ##> ("/smp test smp://LcJU@localhost:" <> smpTestPort alice) + alice <## ("SMP server test failed at Connect, error: BROKER {brokerAddress = \"smp://LcJU@localhost:" <> smpTestPort alice <> "\", brokerErr = NETWORK {networkError = NEUnknownCAError}}") alice <## "Certificate fingerprint in SMP server address does not match server certificate" testGetSetXFTPServers :: HasCallStack => TestParams -> IO () testGetSetXFTPServers = testChat aliceProfile $ - \alice -> withXFTPServer $ do + \alice -> withXFTPServer alice $ do alice ##> "/_servers 1" alice <## "Your servers" alice <## " SMP servers" - alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001" + alice <## (" " <> smpServerStr alice) alice <## " XFTP servers" - alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002" + alice <## (" " <> xftpServerStr alice) alice #$> ("/xftp xftp://1234-w==@xftp1.example.im", id, "ok") alice ##> "/xftp" alice <## "Your servers" @@ -1203,16 +1204,16 @@ testGetSetXFTPServers = testTestXFTPServer :: HasCallStack => TestParams -> IO () testTestXFTPServer = testChat aliceProfile $ - \alice -> withXFTPServer $ do - alice ##> "/xftp test xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7002" + \alice -> withXFTPServer alice $ do + alice ##> ("/xftp test xftp://" <> testServerKeyHash <> "@localhost:" <> xftpTestPort alice) alice <## "XFTP server test passed" -- to test with password: -- alice <## "XFTP server test failed at CreateFile, error: XFTP AUTH" -- alice <## "Server requires authorization to upload files, check password" - alice ##> "/xftp test xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002" + alice ##> ("/xftp test " <> xftpServerStr alice) alice <## "XFTP server test passed" - alice ##> "/xftp test xftp://LcJU@localhost:7002" - alice <## "XFTP server test failed at Connect, error: BROKER {brokerAddress = \"xftp://LcJU@localhost:7002\", brokerErr = NETWORK {networkError = NEUnknownCAError}}" + alice ##> ("/xftp test xftp://LcJU@localhost:" <> xftpTestPort alice) + alice <## ("XFTP server test failed at Connect, error: BROKER {brokerAddress = \"xftp://LcJU@localhost:" <> xftpTestPort alice <> "\", brokerErr = NETWORK {networkError = NEUnknownCAError}}") alice <## "Certificate fingerprint in XFTP server address does not match server certificate" testOperators :: HasCallStack => TestParams -> IO () @@ -1272,11 +1273,9 @@ testAsyncAcceptingOffline withShortLink ps = do bob <## "confirmation sent!" withTestChat ps "alice" $ \alice -> do withTestChat ps "bob" $ \bob -> do - alice <## "subscribed 1 connections on server localhost" - bob <## "subscribed 1 connections on server localhost" concurrently_ - (bob <## "alice (Alice): contact is connected") - (alice <## "bob (Bob): contact is connected") + (bob <### ["subscribed 1 connections on server localhost", "alice (Alice): contact is connected"]) + (alice <### ["subscribed 1 connections on server localhost", "bob (Bob): contact is connected"]) testFullAsyncFast :: HasCallStack => TestParams -> IO () testFullAsyncFast ps = do @@ -1290,11 +1289,9 @@ testFullAsyncFast ps = do bob <## "confirmation sent!" threadDelay 250000 withTestChat ps "alice" $ \alice -> do - alice <## "subscribed 1 connections on server localhost" - alice <## "bob (Bob): contact is connected" + alice <### ["subscribed 1 connections on server localhost", "bob (Bob): contact is connected"] withTestChat ps "bob" $ \bob -> do - bob <## "subscribed 1 connections on server localhost" - bob <## "alice (Alice): contact is connected" + bob <### ["subscribed 1 connections on server localhost", "alice (Alice): contact is connected"] testCallType :: CallType testCallType = CallType {media = CMVideo, capabilities = CallCapabilities {encryption = True}} @@ -1339,7 +1336,7 @@ testNegotiateCall = alice <## "bob accepted your WebRTC video call (e2e encrypted)" repeatM_ 3 $ getTermLine alice threadDelay 100000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: accepted")]) + (alice ##> "/_get chat @2 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` (chatFeatures <> [(1, "outgoing call: accepted")]) -- alice confirms call by sending WebRTC answer alice ##> ("/_call answer @2 " <> serialize testWebRTCSession) alice <## "ok" @@ -1348,7 +1345,7 @@ testNegotiateCall = bob <## "alice continued the WebRTC call" repeatM_ 3 $ getTermLine bob threadDelay 100000 - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: connecting...")]) + (bob ##> "/_get chat @2 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (chatFeatures <> [(0, "incoming call: connecting...")]) -- participants can update calls as connected alice ##> "/_call status @2 connected" alice <## "ok" @@ -1364,7 +1361,7 @@ testNegotiateCall = threadDelay 100000 bob #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(0, "incoming call: ended")]) alice <## "call with bob ended" - alice #$> ("/_get chat @2 count=100", callChat, chatFeatures <> [(1, "outgoing call: ended")]) + (alice ##> "/_get chat @2 count=100" >> callChat <$> getTermLine alice) `shouldEventuallyReturn` (chatFeatures <> [(1, "outgoing call: ended")]) where callChat = map (fmap noDuration) . chat noDuration s = case words s of @@ -1402,6 +1399,7 @@ testNegotiateCallV1 = bob <## "ok" alice <## "bob accepted your WebRTC video call (e2e encrypted)" repeatM_ 3 $ getTermLine alice + (show . callStateTag . callState <$> currentCall alice 2) `shouldEventuallyReturn` "CSTCallOfferReceived" Call {callState = CallOfferReceived {sharedKey = aliceKey}} <- currentCall alice 2 aliceKey `shouldBe` Just bobKey alice ##> ("/_call answer @2 " <> serialize testWebRTCSession) @@ -1437,12 +1435,12 @@ testStopStartChat ps = connectUsers alice bob alice #> "@bob hi" bob <# "alice> hi" - alice #$> ("/_ttl 1 4", id, "ok") - alice ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 2}}" + alice #$> ("/_ttl 1 12", id, "ok") + alice ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 6}}" alice <## "you updated preferences for bob:" - alice <## "Disappearing messages: enabled (you allow: yes (2 sec), contact allows: yes)" + alice <## "Disappearing messages: enabled (you allow: yes (6 sec), contact allows: yes)" bob <## "alice updated preferences for you:" - bob <## "Disappearing messages: enabled (you allow: yes (2 sec), contact allows: yes (2 sec))" + bob <## "Disappearing messages: enabled (you allow: yes (6 sec), contact allows: yes (6 sec))" alice #> "@bob hi timed" bob <# "alice> hi timed" let ChatController {agentAsync, cleanupManagerAsync, expireCIThreads, timedItemThreads} = chatController alice @@ -1460,13 +1458,13 @@ testStopStartChat ps = M.null <$> readTVarIO expireCIThreads `shouldReturn` True M.null <$> readTVarIO timedItemThreads `shouldReturn` True alice ##> "/_start" - alice <## "chat started" - alice <## "subscribed 1 connections on server localhost" + alice <### ["chat started", "subscribed 1 connections on server localhost"] bob #> "@alice hello" alice <# "bob> hello" + threadDelay 3000000 alice <### ["timed message deleted: hi timed", "timed message deleted: hello"] bob <### ["timed message deleted: hi timed", "timed message deleted: hello"] - threadDelay 3000000 + threadDelay 8000000 alice #$> ("/_get chat @2 count=100", chat, [(1, "chat banner")]) Just (a1', _) <- readTVarIO agentAsync (a1' == a1) `shouldBe` False @@ -1487,14 +1485,13 @@ testMaintenanceMode ps = do connectUsers alice bob alice #> "@bob hi" bob <# "alice> hi" - alice ##> "/_db export {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}" + alice ##> ("/_db export {\"archivePath\": \"" <> archive <> "\"}") alice <## "error: chat not stopped" alice ##> "/_stop" alice <## "chat stopped" alice ##> "/_start" - alice <## "chat started" -- chat works after start - alice <## "subscribed 1 connections on server localhost" + alice <### ["chat started", "subscribed 1 connections on server localhost"] alice #> "@bob hi again" bob <# "alice> hi again" bob #> "@alice hello" @@ -1502,32 +1499,38 @@ testMaintenanceMode ps = do -- export / delete / import alice ##> "/_stop" alice <## "chat stopped" - alice ##> "/_db export {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}" + alice ##> ("/_db export {\"archivePath\": \"" <> archive <> "\"}") alice <## "ok" - doesFileExist "./tests/tmp/alice-chat.zip" `shouldReturn` True - alice ##> "/_db import {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}" + doesFileExist archive `shouldReturn` True + alice ##> ("/_db import {\"archivePath\": \"" <> archive <> "\"}") alice <## "ok" -- cannot start chat after import alice ##> "/_start" alice <## "error: chat store changed, please restart chat" -- works after full restart withTestChat ps "alice" $ \alice -> testChatWorking alice bob + where + archive = tmpFile ps "alice-chat.zip" testChatWorking :: HasCallStack => TestCC -> TestCC -> IO () testChatWorking alice bob = do alice <## "subscribed 1 connections on server localhost" + testChatMessages alice bob + +testChatMessages :: HasCallStack => TestCC -> TestCC -> IO () +testChatMessages alice bob = do alice #> "@bob hello again" bob <# "alice> hello again" bob #> "@alice hello too" alice <# "bob> hello too" testMaintenanceModeWithFiles :: HasCallStack => TestParams -> IO () -testMaintenanceModeWithFiles ps = withXFTPServer $ do +testMaintenanceModeWithFiles ps = withXFTPServer ps $ do withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChatOpts ps testOpts {coreOptions = testCoreOpts {maintenance = True}} "alice" aliceProfile $ \alice -> do alice ##> "/_start" alice <## "chat started" - alice ##> "/_files_folder ./tests/tmp/alice_files" + alice ##> ("/_files_folder " <> aliceFiles) alice <## "ok" connectUsers alice bob @@ -1545,7 +1548,7 @@ testMaintenanceModeWithFiles ps = withXFTPServer $ do alice <## "completed receiving file 1 (test.jpg) from bob" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/alice_files/test.jpg" + dest <- B.readFile (aliceFiles "test.jpg") dest `shouldBe` src threadDelay 500000 @@ -1554,7 +1557,7 @@ testMaintenanceModeWithFiles ps = withXFTPServer $ do forM_ backupDBs $ \f -> B.writeFile f "" alice ##> "/_stop" alice <## "chat stopped" - alice ##> "/_db export {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}" + alice ##> ("/_db export {\"archivePath\": \"" <> archive <> "\"}") alice <## "ok" let exportedDBs = [tmpPath ps <> "/alice_chat.db.exported", tmpPath ps <> "/alice_agent.db.exported"] forM_ exportedDBs $ \f -> B.writeFile f "" @@ -1563,14 +1566,17 @@ testMaintenanceModeWithFiles ps = withXFTPServer $ do -- cannot start chat after delete alice ##> "/_start" alice <## "error: chat store changed, please restart chat" - doesDirectoryExist "./tests/tmp/alice_files" `shouldReturn` False + doesDirectoryExist aliceFiles `shouldReturn` False forM_ exportedDBs $ \f -> doesFileExist f `shouldReturn` False - alice ##> "/_db import {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}" + alice ##> ("/_db import {\"archivePath\": \"" <> archive <> "\"}") alice <## "ok" - B.readFile "./tests/tmp/alice_files/test.jpg" `shouldReturn` src + B.readFile (aliceFiles "test.jpg") `shouldReturn` src forM_ backupDBs $ \f -> doesFileExist f `shouldReturn` False -- works after full restart withTestChat ps "alice" $ \alice -> testChatWorking alice bob + where + aliceFiles = tmpFile ps "alice_files" + archive = tmpFile ps "alice-chat.zip" #if !defined(dbPostgres) testDatabaseEncryption :: HasCallStack => TestParams -> IO () @@ -1596,8 +1602,8 @@ testDatabaseEncryption ps = do alice <## "error: chat store changed, please restart chat" withTestChatOpts ps (getTestOpts True "mykey") "alice" $ \alice -> do alice ##> "/_start" - alice <## "chat started" - testChatWorking alice bob + alice <### ["chat started", "subscribed 1 connections on server localhost"] + testChatMessages alice bob alice ##> "/_stop" alice <## "chat stopped" alice ##> "/db test key wrongkey" @@ -1612,8 +1618,8 @@ testDatabaseEncryption ps = do alice <## "ok" withTestChatOpts ps (getTestOpts True "anotherkey") "alice" $ \alice -> do alice ##> "/_start" - alice <## "chat started" - testChatWorking alice bob + alice <### ["chat started", "subscribed 1 connections on server localhost"] + testChatMessages alice bob alice ##> "/_stop" alice <## "chat stopped" alice ##> "/db decrypt anotherkey" @@ -1753,6 +1759,7 @@ testConnSyncExtraAgentConns ps = do alice ##> "/_connections diff" alice <## "no difference between agent and chat connections" + threadDelay 1000000 -- deleting connection record in chat db void $ withCCTransaction alice $ \db -> DB.execute_ db "DELETE FROM connections WHERE contact_id = (SELECT contact_id FROM contacts WHERE local_display_name = 'cath')" @@ -1779,9 +1786,7 @@ testConnSyncExtraAgentConns ps = do alice <## "subscribed 1 connections on server localhost" threadDelay 100000 - agentConnCount <- withCCAgentTransaction alice $ \db -> - DB.query_ db "SELECT count(1) FROM connections" :: IO [[Int]] - agentConnCount `shouldBe` [[1]] + (withCCAgentTransaction alice $ \db -> DB.query_ db "SELECT count(1) FROM connections" :: IO [[Int]]) `shouldEventuallyReturn` [[1]] alice <##> bob @@ -1789,10 +1794,12 @@ testSubscribeAppNSE :: HasCallStack => TestParams -> IO () testSubscribeAppNSE ps = withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "alice" aliceProfile $ \alice -> do + let ChatController {agentAsync} = chatController alice + Just (_, Just subscribed) <- readTVarIO agentAsync + wait subscribed withTestChatOpts ps testOpts {coreOptions = testCoreOpts {maintenance = True}} "alice" $ \nseAlice -> do alice ##> "/_app suspend 1" - alice <## "ok" - alice <## "chat suspended" + alice <### ["ok", "chat suspended"] nseAlice ##> "/_start main=off" nseAlice <## "chat started" threadDelay 100000 @@ -1802,11 +1809,13 @@ testSubscribeAppNSE ps = bob <## "connection request sent!" (nseAlice "/_app activate" - alice <## "ok" - alice <## "subscribed 1 connections on server localhost" - alice <## "bob (Bob) wants to connect to you!" - alice <## "to accept: /ac bob" - alice <## "to reject: /rc bob (the sender will NOT be notified)" + alice + <### [ "ok", + "subscribed 1 connections on server localhost", + "bob (Bob) wants to connect to you!", + "to accept: /ac bob", + "to reject: /rc bob (the sender will NOT be notified)" + ] alice ##> "/ac bob" alice <## "bob (Bob): accepting contact request, you can send messages to contact" concurrently_ @@ -2032,7 +2041,7 @@ testServiceRequestResponse = alice ##> "/_stop" alice <## "chat stopped" alice ##> "/_start main=on snd_files=on service_requests=on" - alice <## "chat started" + alice <### ["chat started", "subscribed 1 connections on server localhost"] concurrently_ ( do bob ##> ("/_service_request 1 " <> sLink <> " {\"ping\":1}") @@ -2057,7 +2066,7 @@ testSignedServiceRequest = alice ##> "/_stop" alice <## "chat stopped" alice ##> "/_start main=on snd_files=on service_requests=on" - alice <## "chat started" + alice <### ["chat started", "subscribed 1 connections on server localhost"] g <- C.newRandom (pub, priv :: C.PrivateKeyEd25519) <- atomically $ C.generateKeyPair g let signKey = B.unpack $ strEncode $ C.StoredPrivateKey priv @@ -2343,17 +2352,17 @@ testUsersDifferentCIExpirationTTL ps = do -- set ttl for first user alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/_ttl 1 2", id, "ok") + alice #$> ("/_ttl 1 10", id, "ok") -- set ttl for second user alice ##> "/user alisa" showActiveUser alice "alisa" - alice #$> ("/_ttl 2 4", id, "ok") + alice #$> ("/_ttl 2 25", id, "ok") -- first user messages alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/ttl", id, "old messages are set to be deleted after: 2 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 10 second(s)") alice #> "@bob alice 3" bob <# "alice> alice 3" @@ -2365,7 +2374,7 @@ testUsersDifferentCIExpirationTTL ps = do -- second user messages alice ##> "/user alisa" showActiveUser alice "alisa" - alice #$> ("/ttl", id, "old messages are set to be deleted after: 4 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 25 second(s)") alice #> "@bob alisa 3" bob <# "alisa> alisa 3" @@ -2374,22 +2383,22 @@ testUsersDifferentCIExpirationTTL ps = do alice #$> ("/_get chat @5 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 3000000 + threadDelay 12000000 -- messages both before and after setting chat item ttl are deleted -- first user messages alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/_get chat @2 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @2 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] -- second user messages alice ##> "/user alisa" showActiveUser alice "alisa" alice #$> ("/_get chat @5 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 2100000 + threadDelay 15000000 - alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @5 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] where cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000} @@ -2398,13 +2407,13 @@ testUsersRestartCIExpiration ps = do withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChatCfg ps cfg "alice" aliceProfile $ \alice -> do -- set ttl for first user - alice #$> ("/_ttl 1 2", id, "ok") + alice #$> ("/_ttl 1 10", id, "ok") connectUsers alice bob -- create second user and set ttl alice ##> "/create user alisa" showActiveUser alice "alisa" - alice #$> ("/_ttl 2 5", id, "ok") + alice #$> ("/_ttl 2 25", id, "ok") connectUsers alice bob -- first user messages @@ -2436,7 +2445,7 @@ testUsersRestartCIExpiration ps = do -- first user messages alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/ttl", id, "old messages are set to be deleted after: 2 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 10 second(s)") alice #> "@bob alice 3" bob <# "alice> alice 3" @@ -2448,7 +2457,7 @@ testUsersRestartCIExpiration ps = do -- second user messages alice ##> "/user alisa" showActiveUser alice "alisa" - alice #$> ("/ttl", id, "old messages are set to be deleted after: 5 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 25 second(s)") alice #> "@bob alisa 3" bob <# "alisa> alisa 3" @@ -2457,22 +2466,22 @@ testUsersRestartCIExpiration ps = do alice #$> ("/_get chat @5 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 3000000 + threadDelay 12000000 -- messages both before and after restart are deleted -- first user messages alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/_get chat @2 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @2 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] -- second user messages alice ##> "/user alisa" showActiveUser alice "alisa" alice #$> ("/_get chat @5 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 4000000 + threadDelay 15000000 - alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @5 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] where cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000} @@ -2558,7 +2567,7 @@ testDisableCIExpirationOnlyForOneUser ps = do -- create second user and set ttl alice ##> "/create user alisa" showActiveUser alice "alisa" - alice #$> ("/_ttl 2 1", id, "ok") + alice #$> ("/_ttl 2 5", id, "ok") connectUsers alice bob -- first user disables expiration @@ -2570,7 +2579,7 @@ testDisableCIExpirationOnlyForOneUser ps = do -- second user still has ttl configured alice ##> "/user alisa" showActiveUser alice "alisa" - alice #$> ("/ttl", id, "old messages are set to be deleted after: 1 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 5 second(s)") alice #> "@bob alisa 1" bob <# "alisa> alisa 1" @@ -2579,17 +2588,17 @@ testDisableCIExpirationOnlyForOneUser ps = do alice #$> ("/_get chat @5 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2")]) - threadDelay 2000000 + threadDelay 6000000 -- second user messages are deleted - alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @5 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] withTestChatCfg ps cfg "alice" $ \alice -> do alice <## "subscribed 1 connections on server localhost" alice <## "subscribed 1 connections on server localhost" -- second user still has ttl configured after restart - alice #$> ("/ttl", id, "old messages are set to be deleted after: 1 second(s)") + alice #$> ("/ttl", id, "old messages are set to be deleted after: 5 second(s)") alice #> "@bob alisa 3" bob <# "alisa> alisa 3" @@ -2598,10 +2607,10 @@ testDisableCIExpirationOnlyForOneUser ps = do alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 3000000 + threadDelay 6000000 -- second user messages are deleted - alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner")]) + (alice ##> "/_get chat @5 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(1,"chat banner")] where cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000} @@ -2610,13 +2619,13 @@ testUsersTimedMessages ps' = do withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "alice" aliceProfile $ \alice -> do connectUsers alice bob - configureTimedMessages alice bob "2" "2" + configureTimedMessages alice bob "2" "10" -- create second user and configure timed messages for contact alice ##> "/create user alisa" showActiveUser alice "alisa" connectUsers alice bob - configureTimedMessages alice bob "5" "3" + configureTimedMessages alice bob "5" "16" -- first user messages alice ##> "/user alice" @@ -2637,7 +2646,7 @@ testUsersTimedMessages ps' = do alice <# "bob> alisa 2" -- messages are deleted after ttl - threadDelay 1500000 + threadDelay 6000000 alice ##> "/user alice" showActiveUser alice "alice (Alice)" @@ -2647,7 +2656,7 @@ testUsersTimedMessages ps' = do showActiveUser alice "alisa" alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner"), (1, "alisa 1"), (0, "alisa 2")]) - threadDelay 1000000 + threadDelay 4000000 alice <### ["[user: alice] timed message deleted: alice 1", "[user: alice] timed message deleted: alice 2"] bob <### ["timed message deleted: alice 1", "timed message deleted: alice 2"] @@ -2660,7 +2669,7 @@ testUsersTimedMessages ps' = do showActiveUser alice "alisa" alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner"), (1, "alisa 1"), (0, "alisa 2")]) - threadDelay 1000000 + threadDelay 7000000 alice <### ["timed message deleted: alisa 1", "timed message deleted: alisa 2"] bob <### ["timed message deleted: alisa 1", "timed message deleted: alisa 2"] @@ -2700,7 +2709,7 @@ testUsersTimedMessages ps' = do alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner"), (1, "alisa 3"), (0, "alisa 4")]) -- messages are deleted after restart - threadDelay 1000000 + threadDelay 8000000 alice <### ["[user: alice] timed message deleted: alice 3", "[user: alice] timed message deleted: alice 4"] bob <### ["timed message deleted: alice 3", "timed message deleted: alice 4"] @@ -2713,7 +2722,7 @@ testUsersTimedMessages ps' = do showActiveUser alice "alisa" alice #$> ("/_get chat @5 count=100", chat, [(1,"chat banner"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 1000000 + threadDelay 8000000 alice <### ["timed message deleted: alisa 3", "timed message deleted: alisa 4"] bob <### ["timed message deleted: alisa 3", "timed message deleted: alisa 4"] @@ -2879,15 +2888,15 @@ testUserPrivacy = testSetChatItemTTL :: HasCallStack => TestParams -> IO () testSetChatItemTTL = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob alice #> "@bob 1" bob <# "alice> 1" bob #> "@alice 2" alice <# "bob> 2" -- chat item with file - alice #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/app_files/test.jpg" + alice #$> ("/_files_folder " <> tmpFile alice "app_files", id, "ok") + copyFile "./tests/fixtures/test.jpg" $ tmpFile alice "app_files/test.jpg" alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" @@ -2895,17 +2904,17 @@ testSetChatItemTTL = bob <## "use /fr 1 [/ | ] to receive it" alice <## "completed uploading file 1 (test.jpg) for bob" -- above items should be deleted after we set ttl - threadDelay 3000000 + threadDelay 6000000 alice #> "@bob 3" bob <# "alice> 3" bob #> "@alice 4" alice <# "bob> 4" alice #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((1, "1"), Nothing), ((0, "2"), Nothing), ((1, ""), Just "test.jpg"), ((1, "3"), Nothing), ((0, "4"), Nothing)]) - checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $ - alice #$> ("/_ttl 1 2", id, "ok") + checkActionDeletesFile (tmpFile alice "app_files/test.jpg") $ + alice #$> ("/_ttl 1 5", id, "ok") alice #$> ("/_get chat @2 count=100", chat, [(1, "chat banner"), (1, "3"), (0, "4")]) -- when expiration is turned on, first cycle is synchronous bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "1"), (1, "2"), (0, ""), (0, "3"), (1, "4")]) - alice #$> ("/_ttl 1", id, "old messages are set to be deleted after: 2 second(s)") + alice #$> ("/_ttl 1", id, "old messages are set to be deleted after: 5 second(s)") alice #$> ("/ttl week", id, "ok") alice #$> ("/ttl", id, "old messages are set to be deleted after: one week") alice #$> ("/ttl none", id, "ok") @@ -2929,13 +2938,13 @@ testSetDirectChatTTL = alice #$> ("/ttl @cath none", id, "ok") alice #$> ("/ttl @cath", id, "old messages are not being deleted") - threadDelay 3000000 + threadDelay 6000000 alice #> "@bob 3" bob <# "alice> 3" bob #> "@alice 4" alice <# "bob> 4" alice #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((1, "1"), Nothing), ((0, "2"), Nothing), ((1, "3"), Nothing), ((0, "4"), Nothing)]) - alice #$> ("/_ttl 1 2", id, "ok") + alice #$> ("/_ttl 1 5", id, "ok") -- when expiration is turned on, first cycle is synchronous alice #$> ("/_get chat @2 count=100", chat, [(1, "chat banner"), (1, "3"), (0, "4")]) @@ -3016,8 +3025,8 @@ testSwitchContact = bob <## "alice changed address for you" alice <## "bob: you changed address" threadDelay 100000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "started changing address..."), (1, "you changed address")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "started changing address for you..."), (0, "changed address for you")]) + (alice ##> "/_get chat @2 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` (chatFeatures <> [(1, "started changing address..."), (1, "you changed address")]) + (bob ##> "/_get chat @2 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (chatFeatures <> [(0, "started changing address for you..."), (0, "changed address for you")]) alice <##> bob testAbortSwitchContact :: HasCallStack => TestParams -> IO () @@ -3036,8 +3045,7 @@ testAbortSwitchContact ps = do alice ##> "/abort switch bob" alice <## "error: command is prohibited, abortConnectionSwitch: not allowed" withTestChat ps "bob" $ \bob -> do - bob <## "subscribed 1 connections on server localhost" - bob <## "alice started changing address for you" + bob <### ["subscribed 1 connections on server localhost", "alice started changing address for you"] -- alice changes address again alice #$> ("/switch bob", id, "switch started") alice <## "bob: you started changing address" @@ -3045,8 +3053,8 @@ testAbortSwitchContact ps = do bob <## "alice changed address for you" alice <## "bob: you changed address" threadDelay 100000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "started changing address..."), (1, "started changing address..."), (1, "you changed address")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")]) + (alice ##> "/_get chat @2 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` (chatFeatures <> [(1, "started changing address..."), (1, "started changing address..."), (1, "you changed address")]) + (bob ##> "/_get chat @2 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (chatFeatures <> [(0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")]) alice <##> bob testSwitchGroupMember :: HasCallStack => TestParams -> IO () @@ -3060,8 +3068,8 @@ testSwitchGroupMember = bob <## "#team: alice changed address for you" alice <## "#team: you changed address for bob" threadDelay 100000 - alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "started changing address for bob..."), (1, "you changed address for bob")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "started changing address for you..."), (0, "changed address for you")]) + (alice ##> "/_get chat #1 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` (sndGroupFeatures <> [(0, "connected"), (1, "started changing address for bob..."), (1, "you changed address for bob")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "started changing address for you..."), (0, "changed address for you")]) alice #> "#team hey" bob <# "#team alice> hey" bob #> "#team hi" @@ -3083,8 +3091,7 @@ testAbortSwitchGroupMember ps = do alice ##> "/abort switch #team bob" alice <## "error: command is prohibited, abortConnectionSwitch: not allowed" withTestChat ps "bob" $ \bob -> do - bob <## "subscribed 2 connections on server localhost" - bob <## "#team: alice started changing address for you" + bob <### ["subscribed 2 connections on server localhost", "#team: alice started changing address for you"] -- alice changes address again alice #$> ("/switch #team bob", id, "switch started") alice <## "#team: you started changing address for bob" @@ -3092,8 +3099,8 @@ testAbortSwitchGroupMember ps = do bob <## "#team: alice changed address for you" alice <## "#team: you changed address for bob" threadDelay 100000 - alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "started changing address for bob..."), (1, "started changing address for bob..."), (1, "you changed address for bob")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")]) + (alice ##> "/_get chat #1 count=100" >> chat <$> getTermLine alice) `shouldEventuallyReturn` (sndGroupFeatures <> [(0, "connected"), (1, "started changing address for bob..."), (1, "started changing address for bob..."), (1, "you changed address for bob")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")]) alice #> "#team hey" bob <# "#team alice> hey" bob #> "#team hi" @@ -3215,8 +3222,7 @@ setupDesynchronizedRatchet ps alice = do alice #> "@bob 2" alice #> "@bob 3" (bob "/tail @alice 1" - bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)" + (bob ##> "/tail @alice 1" >> dropTime <$> getTermLine bob) `shouldEventuallyReturn` "alice> decryption error, possibly due to the device change (header, 3 messages)" bob ##> "@alice 1" bob <## "error: command is prohibited, sendMessagesB: send prohibited" (alice ("/_get chat @2 count=3", chat, [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "connection synchronized")]) - alice #$> ("/_get chat @2 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")]) + (bob ##> "/_get chat @2 count=3" >> chat <$> getTermLine bob) `shouldEventuallyReturn` [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "connection synchronized")] + (alice ##> "/_get chat @2 count=2" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(0, "connection synchronization agreed"), (0, "connection synchronized")] alice #> "@bob hello again" bob <# "alice> hello again" @@ -3286,8 +3292,8 @@ testSyncRatchetCodeReset ps = bob <## "alice: connection synchronized" threadDelay 100000 - bob #$> ("/_get chat @2 count=4", chat, [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")]) - alice #$> ("/_get chat @2 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")]) + (bob ##> "/_get chat @2 count=4" >> chat <$> getTermLine bob) `shouldEventuallyReturn` [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")] + (alice ##> "/_get chat @2 count=2" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(0, "connection synchronization agreed"), (0, "connection synchronized")] -- connection not verified bob ##> "/i alice" diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 14851444a7..6c5ae61704 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -29,6 +29,7 @@ import Simplex.Messaging.Crypto.BBS (BBSPublicKey, bbsKeyGen) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize) +import System.FilePath (()) import Test.Hspec hiding (it) chatFileTests :: SpecWith TestParams @@ -79,8 +80,9 @@ chatFileTests = do it "file proof is rejected under another binding, size or expired badge" testFileBadgeProofStatus runTestMessageWithFile :: HasCallStack => TestParams -> IO () -runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do +runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withXFTPServer alice $ do connectUsers alice bob + let testJpg = tmpFile bob "test.jpg" alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"file\", \"text\": \"hi, sending a file\"}}]" alice <# "@bob hi, sending a file" @@ -91,9 +93,9 @@ runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withX bob <## "use /fr 1 [/ | ] to receive it" alice <## "completed uploading file 1 (test.jpg) for bob" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> testJpg, "started receiving file 1 (test.jpg) from alice" ] bob <## "completed receiving file 1 (test.jpg) from alice" @@ -101,7 +103,7 @@ runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withX alice <# "bob> received" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile testJpg dest `shouldBe` src alice #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((1, "hi, sending a file"), Just "./tests/fixtures/test.jpg"), ((0, "received"), Nothing)]) @@ -109,10 +111,10 @@ runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withX alice <## "Chat content types: file, text" alice #$> ("/_get chat @2 content=file count=100", chatF, [((1, "hi, sending a file"), Just "./tests/fixtures/test.jpg")]) - bob #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((0, "hi, sending a file"), Just "./tests/tmp/test.jpg"), ((1, "received"), Nothing)]) + bob #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((0, "hi, sending a file"), Just testJpg), ((1, "received"), Nothing)]) bob ##> "/_get content types @2" bob <## "Chat content types: file, text" - bob #$> ("/_get chat @2 content=file count=100", chatF, [((0, "hi, sending a file"), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat @2 content=file count=100", chatF, [((0, "hi, sending a file"), Just testJpg)]) -- Test file with link in text - should appear in both file and link filters alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"check https://example.com for docs\"}}]" @@ -131,14 +133,15 @@ runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withX bob ##> "/_get content types @2" bob <## "Chat content types: file, text" - bob #$> ("/_get chat @2 content=file count=100", chatF, [((0, "hi, sending a file"), Just "./tests/tmp/test.jpg"), ((0, "check https://example.com for docs"), Nothing)]) + bob #$> ("/_get chat @2 content=file count=100", chatF, [((0, "hi, sending a file"), Just testJpg), ((0, "check https://example.com for docs"), Nothing)]) bob #$> ("/_get chat @2 content=link count=100", chatF, [((0, "check https://example.com for docs"), Nothing)]) testSendImage :: HasCallStack => TestParams -> IO () testSendImage = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob + let testJpg = tmpFile bob "test.jpg" alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" @@ -146,29 +149,29 @@ testSendImage = bob <## "use /fr 1 [/ | ] to receive it" alice <## "completed uploading file 1 (test.jpg) for bob" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> testJpg, "started receiving file 1 (test.jpg) from alice" ] bob <## "completed receiving file 1 (test.jpg) from alice" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile testJpg dest `shouldBe` src alice #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((1, ""), Just "./tests/fixtures/test.jpg")]) - bob #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((0, ""), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((0, ""), Just testJpg)]) -- deleting contact without files folder set should not remove file bob ##> "/d alice" bob <## "alice: contact is deleted" alice <## "bob (Bob) deleted contact with you" - fileExists <- doesFileExist "./tests/tmp/test.jpg" + fileExists <- doesFileExist testJpg fileExists `shouldBe` True testSenderMarkItemDeleted :: HasCallStack => TestParams -> IO () testSenderMarkItemDeleted = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test_1MB.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}]" alice <# "@bob hi, sending a file" @@ -182,7 +185,7 @@ testSenderMarkItemDeleted = alice #$> ("/_delete item @2 " <> itemId 1 <> " broadcast", id, "message marked deleted") bob <# "alice> [marked deleted] hi, sending a file" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob <## "file cancelled: test_1MB.pdf" bob ##> "/fs 1" @@ -191,10 +194,11 @@ testSenderMarkItemDeleted = testFilesFoldersSendImage :: HasCallStack => TestParams -> IO () testFilesFoldersSendImage = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob + let bobFiles = tmpFile bob "app_files" alice #$> ("/_files_folder ./tests/fixtures", id, "ok") - bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" @@ -210,12 +214,12 @@ testFilesFoldersSendImage = bob <## "completed receiving file 1 (test.jpg) from alice" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/app_files/test.jpg" + dest <- B.readFile (bobFiles "test.jpg") dest `shouldBe` src alice #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((1, ""), Just "test.jpg")]) bob #$> ("/_get chat @2 count=100", chatF, chatFeaturesF <> [((0, ""), Just "test.jpg")]) -- deleting contact with files folder set should remove file - checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $ do + checkActionDeletesFile (bobFiles "test.jpg") $ do bob ##> "/d alice" bob <## "alice: contact is deleted" alice <## "bob (Bob) deleted contact with you" @@ -223,11 +227,13 @@ testFilesFoldersSendImage = testFilesFoldersImageSndDelete :: HasCallStack => TestParams -> IO () testFilesFoldersImageSndDelete = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob - alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") - copyFile "./tests/fixtures/test_1MB.pdf" "./tests/tmp/alice_app_files/test_1MB.pdf" - bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") + let aliceFiles = tmpFile alice "alice_app_files" + bobFiles = tmpFile bob "bob_app_files" + alice #$> ("/_files_folder " <> aliceFiles, id, "ok") + copyFile "./tests/fixtures/test_1MB.pdf" (aliceFiles "test_1MB.pdf") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") alice ##> "/_send @2 json [{\"filePath\": \"test_1MB.pdf\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test_1MB.pdf" alice <## "use /fc 1 to cancel sending" @@ -243,23 +249,24 @@ testFilesFoldersImageSndDelete = bob <## "completed receiving file 1 (test_1MB.pdf) from alice" -- deleting contact should remove file - checkActionDeletesFile "./tests/tmp/alice_app_files/test_1MB.pdf" $ do + checkActionDeletesFile (aliceFiles "test_1MB.pdf") $ do alice ##> "/d bob" alice <## "bob: contact is deleted" bob <## "alice (Alice) deleted contact with you" bob ##> "/fs 1" bob <##. "receiving file 1 (test_1MB.pdf) complete" - checkActionDeletesFile "./tests/tmp/bob_app_files/test_1MB.pdf" $ do + checkActionDeletesFile (bobFiles "test_1MB.pdf") $ do bob ##> "/d alice" bob <## "alice: contact is deleted" testFilesFoldersImageRcvDelete :: HasCallStack => TestParams -> IO () testFilesFoldersImageRcvDelete = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob + let bobFiles = tmpFile bob "app_files" alice #$> ("/_files_folder ./tests/fixtures", id, "ok") - bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" @@ -275,7 +282,7 @@ testFilesFoldersImageRcvDelete = bob <## "completed receiving file 1 (test.jpg) from alice" -- deleting contact should remove file - checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $ do + checkActionDeletesFile (bobFiles "test.jpg") $ do bob ##> "/d alice" bob <## "alice: contact is deleted" alice <## "bob (Bob) deleted contact with you" @@ -283,7 +290,7 @@ testFilesFoldersImageRcvDelete = testSendImageWithTextAndQuote :: HasCallStack => TestParams -> IO () testSendImageWithTextAndQuote = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do + \alice bob -> withXFTPServer alice $ do connectUsers alice bob bob #> "@alice hi alice" alice <# "bob> hi alice" @@ -298,18 +305,18 @@ testSendImageWithTextAndQuote = bob <## "use /fr 1 [/ | ] to receive it" alice <## "completed uploading file 1 (test.jpg) for bob" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile bob "test.jpg", "started receiving file 1 (test.jpg) from alice" ] bob <## "completed receiving file 1 (test.jpg) from alice" src <- B.readFile "./tests/fixtures/test.jpg" - B.readFile "./tests/tmp/test.jpg" `shouldReturn` src + B.readFile (tmpFile bob "test.jpg") `shouldReturn` src alice #$> ("/_get chat @2 count=100", chat'', chatFeatures'' <> [((0, "hi alice"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi alice"), Just "./tests/fixtures/test.jpg")]) alice @@@ [("@bob", "hey bob")] - bob #$> ("/_get chat @2 count=100", chat'', chatFeatures'' <> [((1, "hi alice"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi alice"), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat @2 count=100", chat'', chatFeatures'' <> [((1, "hi alice"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi alice"), Just $ tmpFile bob "test.jpg")]) bob @@@ [("@alice", "hey bob")] -- quoting (file + text) with file uses quoted text @@ -324,15 +331,15 @@ testSendImageWithTextAndQuote = alice <## "use /fr 2 [/ | ] to receive it" bob <## "completed uploading file 2 (test.pdf) for alice" - alice ##> "/fr 2 ./tests/tmp" + alice ##> ("/fr 2 " <> tmpDir alice) alice - <### [ "saving file 2 from bob to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 2 from bob to " <> tmpFile alice "test.pdf", "started receiving file 2 (test.pdf) from bob" ] alice <## "completed receiving file 2 (test.pdf) from bob" txtSrc <- B.readFile "./tests/fixtures/test.pdf" - B.readFile "./tests/tmp/test.pdf" `shouldReturn` txtSrc + B.readFile (tmpFile alice "test.pdf") `shouldReturn` txtSrc -- quoting (file without text) with file uses file name alice ##> ("/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> itemId 3 <> ", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]") @@ -346,20 +353,22 @@ testSendImageWithTextAndQuote = bob <## "use /fr 3 [/ | ] to receive it" alice <## "completed uploading file 3 (test.jpg) for bob" - bob ##> "/fr 3 ./tests/tmp" + bob ##> ("/fr 3 " <> tmpDir bob) bob - <### [ "saving file 3 from alice to ./tests/tmp/test_1.jpg", + <### [ ConsoleString $ "saving file 3 from alice to " <> tmpFile bob "test_1.jpg", "started receiving file 3 (test.jpg) from alice" ] bob <## "completed receiving file 3 (test.jpg) from alice" - B.readFile "./tests/tmp/test_1.jpg" `shouldReturn` src + B.readFile (tmpFile bob "test_1.jpg") `shouldReturn` src testGroupSendImage :: HasCallStack => TestParams -> IO () testGroupSendImage = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup3 "team" alice bob cath + let bobJpg = tmpFile bob "test.jpg" + cathJpg = tmpFile cath "test_1.jpg" threadDelay 1000000 alice ##> "/_send #1 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f #team ./tests/fixtures/test.jpg" @@ -374,16 +383,16 @@ testGroupSendImage = ] alice <## "completed uploading file 1 (test.jpg) for #team" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> bobJpg, "started receiving file 1 (test.jpg) from alice" ] bob <## "completed receiving file 1 (test.jpg) from alice" - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from alice to ./tests/tmp/test_1.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> cathJpg, "started receiving file 1 (test.jpg) from alice" ] cath <## "completed receiving file 1 (test.jpg) from alice" @@ -395,9 +404,9 @@ testGroupSendImage = [alice, bob] *<# "#team cath> received too" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile bobJpg dest `shouldBe` src - dest2 <- B.readFile "./tests/tmp/test_1.jpg" + dest2 <- B.readFile cathJpg dest2 `shouldBe` src alice #$> ("/_get chat #1 count=3", chatF, [((1, ""), Just "./tests/fixtures/test.jpg"), ((0, "received"), Nothing), ((0, "received too"), Nothing)]) @@ -405,21 +414,23 @@ testGroupSendImage = alice <## "Chat content types: image, text" alice #$> ("/_get chat #1 content=image count=100", chatF, [((1, ""), Just "./tests/fixtures/test.jpg")]) - bob #$> ("/_get chat #1 count=3", chatF, [((0, ""), Just "./tests/tmp/test.jpg"), ((1, "received"), Nothing), ((0, "received too"), Nothing)]) + bob #$> ("/_get chat #1 count=3", chatF, [((0, ""), Just bobJpg), ((1, "received"), Nothing), ((0, "received too"), Nothing)]) bob ##> "/_get content types #1" bob <## "Chat content types: image, text" - bob #$> ("/_get chat #1 content=image count=100", chatF, [((0, ""), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat #1 content=image count=100", chatF, [((0, ""), Just bobJpg)]) - cath #$> ("/_get chat #1 count=3", chatF, [((0, ""), Just "./tests/tmp/test_1.jpg"), ((0, "received"), Nothing), ((1, "received too"), Nothing)]) + cath #$> ("/_get chat #1 count=3", chatF, [((0, ""), Just cathJpg), ((0, "received"), Nothing), ((1, "received too"), Nothing)]) cath ##> "/_get content types #1" cath <## "Chat content types: image, text" - cath #$> ("/_get chat #1 content=image count=100", chatF, [((0, ""), Just "./tests/tmp/test_1.jpg")]) + cath #$> ("/_get chat #1 content=image count=100", chatF, [((0, ""), Just cathJpg)]) testGroupSendImageWithTextAndQuote :: HasCallStack => TestParams -> IO () testGroupSendImageWithTextAndQuote = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup3 "team" alice bob cath + let bobJpg = tmpFile bob "test.jpg" + cathJpg = tmpFile cath "test_1.jpg" threadDelay 1000000 bob #> "#team hi team" concurrently_ @@ -446,42 +457,44 @@ testGroupSendImageWithTextAndQuote = ] alice <## "completed uploading file 1 (test.jpg) for #team" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> bobJpg, "started receiving file 1 (test.jpg) from alice" ] bob <## "completed receiving file 1 (test.jpg) from alice" - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from alice to ./tests/tmp/test_1.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> cathJpg, "started receiving file 1 (test.jpg) from alice" ] cath <## "completed receiving file 1 (test.jpg) from alice" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile bobJpg dest `shouldBe` src - dest2 <- B.readFile "./tests/tmp/test_1.jpg" + dest2 <- B.readFile cathJpg dest2 `shouldBe` src alice #$> ("/_get chat #1 count=2", chat'', [((0, "hi team"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi team"), Just "./tests/fixtures/test.jpg")]) alice @@@ [("#team", "hey bob"), ("@bob", "sent invitation to join group team as admin"), ("@cath", "sent invitation to join group team as admin")] - bob #$> ("/_get chat #1 count=2", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat #1 count=2", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just bobJpg)]) bob @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] - cath #$> ("/_get chat #1 count=2", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just "./tests/tmp/test_1.jpg")]) + cath #$> ("/_get chat #1 count=2", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just cathJpg)]) cath @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] testSendMultiFilesDirect :: HasCallStack => TestParams -> IO () testSendMultiFilesDirect = testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob - alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" - copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf" - bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") + let aliceFiles = tmpFile alice "alice_app_files" + bobFiles = tmpFile bob "bob_app_files" + alice #$> ("/_files_folder " <> aliceFiles, id, "ok") + copyFile "./tests/fixtures/test.jpg" (aliceFiles "test.jpg") + copyFile "./tests/fixtures/test.pdf" (aliceFiles "test.pdf") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") let cm1 = "{\"msgContent\": {\"type\": \"text\", \"text\": \"message without file\"}}" cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 1\"}}" @@ -525,12 +538,12 @@ testSendMultiFilesDirect = ] bob <## "completed receiving file 2 (test.pdf) from alice" - src1 <- B.readFile "./tests/tmp/alice_app_files/test.jpg" - dest1 <- B.readFile "./tests/tmp/bob_app_files/test.jpg" + src1 <- B.readFile (aliceFiles "test.jpg") + dest1 <- B.readFile (bobFiles "test.jpg") dest1 `shouldBe` src1 - src2 <- B.readFile "./tests/tmp/alice_app_files/test.pdf" - dest2 <- B.readFile "./tests/tmp/bob_app_files/test.pdf" + src2 <- B.readFile (aliceFiles "test.pdf") + dest2 <- B.readFile (bobFiles "test.pdf") dest2 `shouldBe` src2 alice #$> ("/_get chat @2 count=3", chatF, [((1, "message without file"), Nothing), ((1, "sending file 1"), Just "test.jpg"), ((1, "sending file 2"), Just "test.pdf")]) @@ -539,16 +552,19 @@ testSendMultiFilesDirect = testSendMultiFilesGroup :: HasCallStack => TestParams -> IO () testSendMultiFilesGroup = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - withXFTPServer $ do + withXFTPServer alice $ do createGroup3 "team" alice bob cath threadDelay 1000000 - alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" - copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf" - bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") - cath #$> ("/_files_folder ./tests/tmp/cath_app_files", id, "ok") + let aliceFiles = tmpFile alice "alice_app_files" + bobFiles = tmpFile bob "bob_app_files" + cathFiles = tmpFile cath "cath_app_files" + alice #$> ("/_files_folder " <> aliceFiles, id, "ok") + copyFile "./tests/fixtures/test.jpg" (aliceFiles "test.jpg") + copyFile "./tests/fixtures/test.pdf" (aliceFiles "test.pdf") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") + cath #$> ("/_files_folder " <> cathFiles, id, "ok") let cm1 = "{\"msgContent\": {\"type\": \"text\", \"text\": \"message without file\"}}" cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 1\"}}" @@ -616,15 +632,15 @@ testSendMultiFilesGroup = ] cath <## "completed receiving file 2 (test.pdf) from alice" - src1 <- B.readFile "./tests/tmp/alice_app_files/test.jpg" - dest1_1 <- B.readFile "./tests/tmp/bob_app_files/test.jpg" - dest1_2 <- B.readFile "./tests/tmp/cath_app_files/test.jpg" + src1 <- B.readFile (aliceFiles "test.jpg") + dest1_1 <- B.readFile (bobFiles "test.jpg") + dest1_2 <- B.readFile (cathFiles "test.jpg") dest1_1 `shouldBe` src1 dest1_2 `shouldBe` src1 - src2 <- B.readFile "./tests/tmp/alice_app_files/test.pdf" - dest2_1 <- B.readFile "./tests/tmp/bob_app_files/test.pdf" - dest2_2 <- B.readFile "./tests/tmp/cath_app_files/test.pdf" + src2 <- B.readFile (aliceFiles "test.pdf") + dest2_1 <- B.readFile (bobFiles "test.pdf") + dest2_2 <- B.readFile (cathFiles "test.pdf") dest2_1 `shouldBe` src2 dest2_2 `shouldBe` src2 @@ -648,18 +664,19 @@ testXFTPRoundFDCount = do testXFTPFileTransfer :: HasCallStack => TestParams -> IO () testXFTPFileTransfer = testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob + let testPdf = tmpFile bob "test.pdf" alice #> "/f @bob ./tests/fixtures/test.pdf" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) concurrentlyN_ [ alice <## "completed uploading file 1 (test.pdf) for bob", bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> testPdf, "started receiving file 1 (test.pdf) from alice" ] ] @@ -668,10 +685,10 @@ testXFTPFileTransfer = alice ##> "/fs 1" alice <## "sending file 1 (test.pdf) complete" bob ##> "/fs 1" - bob <## "receiving file 1 (test.pdf) complete, path: ./tests/tmp/test.pdf" + bob <## ("receiving file 1 (test.pdf) complete, path: " <> testPdf) src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile testPdf dest `shouldBe` src testXFTPFileTransferEncrypted :: HasCallStack => TestParams -> IO () @@ -679,32 +696,35 @@ testXFTPFileTransferEncrypted = testChat2 aliceProfile bobProfile $ \alice bob -> do src <- B.readFile "./tests/fixtures/test.pdf" srcLen <- getFileSize "./tests/fixtures/test.pdf" - let srcPath = "./tests/tmp/alice/test.pdf" - createDirectoryIfMissing True "./tests/tmp/alice/" - createDirectoryIfMissing True "./tests/tmp/bob/" + let srcPath = tmpFile alice "alice/test.pdf" + bobDir = tmpFile bob "bob/" + createDirectoryIfMissing True $ tmpFile alice "alice/" + createDirectoryIfMissing True bobDir WFResult cfArgs <- chatWriteFile (chatController alice) srcPath src let fileJSON = LB.unpack $ J.encode $ CryptoFile srcPath $ Just cfArgs - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob alice ##> ("/_send @2 json [{\"msgContent\":{\"type\":\"file\", \"text\":\"\"}, \"fileSource\": " <> fileJSON <> "}]") - alice <# "/f @bob ./tests/tmp/alice/test.pdf" + alice <# ("/f @bob " <> srcPath) alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob ##> "/fr 1 encrypt=on ./tests/tmp/bob/" - bob <## "saving file 1 from alice to ./tests/tmp/bob/test.pdf" + bob ##> ("/fr 1 encrypt=on " <> bobDir) + bob + <### [ ConsoleString $ "saving file 1 from alice to " <> bobDir <> "test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] alice <## "completed uploading file 1 (test.pdf) for bob" - bob <## "started receiving file 1 (test.pdf) from alice" bob <## "completed receiving file 1 (test.pdf) from alice" Just (CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine bob - Right dest <- chatReadFile "./tests/tmp/bob/test.pdf" (strEncode key) (strEncode nonce) + Right dest <- chatReadFile (bobDir <> "test.pdf") (strEncode key) (strEncode nonce) LB.length dest `shouldBe` fromIntegral srcLen LB.toStrict dest `shouldBe` src testXFTPAcceptAfterUpload :: HasCallStack => TestParams -> IO () testXFTPAcceptAfterUpload = testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob alice #> "/f @bob ./tests/fixtures/test.pdf" @@ -715,21 +735,21 @@ testXFTPAcceptAfterUpload = threadDelay 100000 - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile bob "test.pdf", "started receiving file 1 (test.pdf) from alice" ] bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile bob "test.pdf") dest `shouldBe` src testXFTPGroupFileTransfer :: HasCallStack => TestParams -> IO () testXFTPGroupFileTransfer = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - withXFTPServer $ do + withXFTPServer alice $ do createGroup3 "team" alice bob cath alice #> "/f #team ./tests/fixtures/test.pdf" @@ -744,23 +764,23 @@ testXFTPGroupFileTransfer = ] alice <## "completed uploading file 1 (test.pdf) for #team" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile bob "test.pdf", "started receiving file 1 (test.pdf) from alice" ] bob <## "completed receiving file 1 (test.pdf) from alice" - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from alice to ./tests/tmp/test_1.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile cath "test_1.pdf", "started receiving file 1 (test.pdf) from alice" ] cath <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest1 <- B.readFile "./tests/tmp/test.pdf" - dest2 <- B.readFile "./tests/tmp/test_1.pdf" + dest1 <- B.readFile (tmpFile bob "test.pdf") + dest2 <- B.readFile (tmpFile cath "test_1.pdf") dest1 `shouldBe` src dest2 `shouldBe` src @@ -775,7 +795,7 @@ testXFTPFileBadgeProof ps = do Right (pk, sk) <- bbsKeyGen testChatCfg2 (badgeFileCfg pk) aliceProfile bobProfile (test sk) ps where - test sk alice bob = withXFTPServer $ do + test sk alice bob = withXFTPServer ps $ do connectUsers alice bob addTestBadge alice =<< issueTestBadge sk futureDate @@ -783,18 +803,18 @@ testXFTPFileBadgeProof ps = do alice <## "use /fc 1 to cancel sending" bob <# "alice *> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) concurrentlyN_ [ alice <## "completed uploading file 1 (test.pdf) for bob", bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from alice" ] ] bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile ps "test.pdf") dest `shouldBe` src testXFTPGroupFileBadgeProof :: HasCallStack => TestParams -> IO () @@ -802,7 +822,7 @@ testXFTPGroupFileBadgeProof ps = do Right (pk, sk) <- bbsKeyGen testChatCfg3 (badgeFileCfg pk) aliceProfile bobProfile cathProfile (test sk) ps where - test sk alice bob cath = withXFTPServer $ do + test sk alice bob cath = withXFTPServer ps $ do createGroup3 "team" alice bob cath addTestBadge alice =<< issueTestBadge sk futureDate @@ -818,28 +838,28 @@ testXFTPGroupFileBadgeProof ps = do ] alice <## "completed uploading file 1 (test.pdf) for #team" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from alice" ] bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile ps "test.pdf") dest `shouldBe` src testXFTPFileNoBadgeProof :: HasCallStack => TestParams -> IO () testXFTPFileNoBadgeProof ps = withNewTestChatCfg ps sndCfg "alice" aliceProfile $ \alice -> - withNewTestChatCfg ps rcvCfg "bob" bobProfile $ \bob -> withXFTPServer $ do + withNewTestChatCfg ps rcvCfg "bob" bobProfile $ \bob -> withXFTPServer ps $ do connectUsers alice bob alice #> "/f @bob ./tests/fixtures/test.pdf" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "file is above the limit of 100000 bytes: sender has no badge" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) concurrentlyN_ [ bob <## "file size exceeds the limit: test.pdf", alice <## "completed uploading file 1 (test.pdf) for bob" @@ -852,7 +872,7 @@ testXFTPFileBadgeAboveLimit :: HasCallStack => TestParams -> IO () testXFTPFileBadgeAboveLimit ps = do Right (pk, sk) <- bbsKeyGen withNewTestChatCfg ps (badgeFileCfg pk) "alice" aliceProfile $ \alice -> - withNewTestChatCfg ps (rcvCfg pk) "bob" bobProfile $ \bob -> withXFTPServer $ do + withNewTestChatCfg ps (rcvCfg pk) "bob" bobProfile $ \bob -> withXFTPServer ps $ do connectUsers alice bob addTestBadge alice =<< issueTestBadge sk futureDate @@ -860,7 +880,7 @@ testXFTPFileBadgeAboveLimit ps = do alice <## "use /fc 1 to cancel sending" bob <# "alice *> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "file is above the limit of 150000 bytes: above the limit of the sender badge" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) concurrentlyN_ [ bob <## "file size exceeds the limit: test.pdf", alice <## "completed uploading file 1 (test.pdf) for bob" @@ -874,7 +894,7 @@ testXFTPSndFileBadgeLimit ps = do testChatCfg2 (cfg pk) aliceProfile bobProfile (test sk) ps where cfg pk = badgeFileCfgLimits pk FileSizeLimits {noBadge = 100000, supporter = 150000, legend = 300000} - test sk alice bob = withXFTPServer $ do + test sk alice bob = withXFTPServer ps $ do connectUsers alice bob addTestBadge alice =<< issueTestBadgeType sk BTSupporter futureDate @@ -896,7 +916,7 @@ testXFTPSndFileBadgeGrace ps = do Right (pk, sk) <- bbsKeyGen testChatCfg2 (badgeFileCfg pk) aliceProfile bobProfile (test sk) ps where - test sk alice bob = withXFTPServer $ do + test sk alice bob = withXFTPServer ps $ do connectUsers alice bob now <- getCurrentTime @@ -941,7 +961,7 @@ testFileBadgeProofStatus ps = do testXFTPDeleteUploadedFile :: HasCallStack => TestParams -> IO () testXFTPDeleteUploadedFile = testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob alice #> "/f @bob ./tests/fixtures/test.pdf" @@ -956,14 +976,15 @@ testXFTPDeleteUploadedFile = bob <## "alice cancelled sending file 1 (test.pdf)" ] - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob <## "file cancelled: test.pdf" testXFTPDeleteUploadedFileGroup :: HasCallStack => TestParams -> IO () testXFTPDeleteUploadedFileGroup = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - withXFTPServer $ do + withXFTPServer alice $ do createGroup3 "team" alice bob cath + let testPdf = tmpFile bob "test.pdf" alice #> "/f #team ./tests/fixtures/test.pdf" alice <## "use /fc 1 to cancel sending" @@ -977,9 +998,9 @@ testXFTPDeleteUploadedFileGroup = ] alice <## "completed uploading file 1 (test.pdf) for #team" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> testPdf, "started receiving file 1 (test.pdf) from alice" ] bob <## "completed receiving file 1 (test.pdf) from alice" @@ -987,12 +1008,12 @@ testXFTPDeleteUploadedFileGroup = alice ##> "/fs 1" alice <## "sending file 1 (test.pdf) complete" bob ##> "/fs 1" - bob <## "receiving file 1 (test.pdf) complete, path: ./tests/tmp/test.pdf" + bob <## ("receiving file 1 (test.pdf) complete, path: " <> testPdf) cath ##> "/fs 1" cath <## "receiving file 1 (test.pdf) not accepted yet, use /fr 1 to receive file" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile testPdf dest `shouldBe` src alice ##> "/fc 1" @@ -1006,21 +1027,21 @@ testXFTPDeleteUploadedFileGroup = alice ##> "/fs 1" alice <## "sending file 1 (test.pdf) cancelled" bob ##> "/fs 1" - bob <## "receiving file 1 (test.pdf) complete, path: ./tests/tmp/test.pdf" + bob <## ("receiving file 1 (test.pdf) complete, path: " <> testPdf) cath ##> "/fs 1" cath <## "receiving file 1 (test.pdf) cancelled" - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath <## "file cancelled: test.pdf" testXFTPWithRelativePaths :: HasCallStack => TestParams -> IO () testXFTPWithRelativePaths = testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do -- agent is passed xftp work directory only on chat start, -- so for test we work around by stopping and starting chat - setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" - setRelativePaths bob "./tests/tmp/bob_files" "./tests/tmp/bob_xftp" + setRelativePaths alice "./tests/fixtures" (tmpFile alice "alice_xftp") + setRelativePaths bob (tmpFile bob "bob_files") (tmpFile bob "bob_xftp") connectUsers alice bob alice #> "/f @bob test.pdf" @@ -1038,12 +1059,12 @@ testXFTPWithRelativePaths = bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/bob_files/test.pdf" + dest <- B.readFile (tmpFile bob "bob_files/test.pdf") dest `shouldBe` src testXFTPContinueRcv :: HasCallStack => TestParams -> IO () testXFTPContinueRcv ps = do - withXFTPServer $ do + withXFTPServer ps $ do withNewTestChat ps "alice" aliceProfile $ \alice -> do withNewTestChat ps "bob" bobProfile $ \bob -> do connectUsers alice bob @@ -1057,9 +1078,9 @@ testXFTPContinueRcv ps = do -- server is down - file is not received withTestChat ps "bob" $ \bob -> do bob <## "subscribed 1 connections on server localhost" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from alice" ] @@ -1068,19 +1089,19 @@ testXFTPContinueRcv ps = do (bob do bob <## "subscribed 1 connections on server localhost" bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile ps "test.pdf") dest `shouldBe` src testXFTPMarkToReceive :: HasCallStack => TestParams -> IO () testXFTPMarkToReceive = do testChat2 aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do + withXFTPServer alice $ do connectUsers alice bob alice #> "/f @bob ./tests/fixtures/test.pdf" @@ -1095,8 +1116,8 @@ testXFTPMarkToReceive = do bob ##> "/_stop" bob <## "chat stopped" - bob #$> ("/_files_folder ./tests/tmp/bob_files", id, "ok") - bob #$> ("/_temp_folder ./tests/tmp/bob_xftp", id, "ok") + bob #$> ("/_files_folder " <> tmpFile bob "bob_files", id, "ok") + bob #$> ("/_temp_folder " <> tmpFile bob "bob_xftp", id, "ok") threadDelay 100000 @@ -1111,12 +1132,12 @@ testXFTPMarkToReceive = do bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/bob_files/test.pdf" + dest <- B.readFile (tmpFile bob "bob_files/test.pdf") dest `shouldBe` src testXFTPRcvError :: HasCallStack => TestParams -> IO () testXFTPRcvError ps = do - withXFTPServer $ do + withXFTPServer ps $ do withNewTestChat ps "alice" aliceProfile $ \alice -> do withNewTestChat ps "bob" bobProfile $ \bob -> do connectUsers alice bob @@ -1128,12 +1149,12 @@ testXFTPRcvError ps = do alice <## "completed uploading file 1 (test.pdf) for bob" -- server is up w/t store log - file reception should fail - withXFTPServer' xftpServerConfig {serverStoreCfg = XSCMemory Nothing, storeLogFile = Nothing} $ do + withXFTPServer' (xftpServerConfig ps) {serverStoreCfg = XSCMemory Nothing, storeLogFile = Nothing} $ do withTestChat ps "bob" $ \bob -> do bob <## "subscribed 1 connections on server localhost" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir ps) bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from alice" ] bob <## "error receiving file 1 (test.pdf) from alice" @@ -1145,20 +1166,22 @@ testXFTPRcvError ps = do testXFTPCancelRcvRepeat :: HasCallStack => TestParams -> IO () testXFTPCancelRcvRepeat = testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do - withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile"] + withXFTPServer alice $ do + let testfile = tmpFile alice "testfile" + testfile1 = tmpFile bob "testfile_1" + xftpCLI ["rand", testfile, "17mb"] `shouldReturn` ["File created: " <> testfile] connectUsers alice bob - alice #> "/f @bob ./tests/tmp/testfile" + alice #> ("/f @bob " <> testfile) alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file testfile (17.0 MiB / 17825792 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) concurrentlyN_ [ alice <## "completed uploading file 1 (testfile) for bob", bob - <### [ "saving file 1 from alice to ./tests/tmp/testfile_1", + <### [ ConsoleString $ "saving file 1 from alice to " <> testfile1, "started receiving file 1 (testfile) from alice" ] ] @@ -1169,33 +1192,35 @@ testXFTPCancelRcvRepeat = bob <##. "receiving file 1 (testfile) progress" bob ##> "/fc 1" - bob <## "cancelled receiving file 1 (testfile) from alice" + bob + <### [ "cancelled receiving file 1 (testfile) from alice", + StartsWith "chat db error: SERcvFileNotFoundXFTP" + ] bob ##> "/fs 1" bob <## "receiving file 1 (testfile) not accepted yet, use /fr 1 to receive file" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) bob - <### [ "saving file 1 from alice to ./tests/tmp/testfile_1", - "started receiving file 1 (testfile) from alice", - StartsWith "chat db error: SERcvFileNotFoundXFTP" + <### [ ConsoleString $ "saving file 1 from alice to " <> testfile1, + "started receiving file 1 (testfile) from alice" ] bob <## "completed receiving file 1 (testfile) from alice" bob ##> "/fs 1" - bob <## "receiving file 1 (testfile) complete, path: ./tests/tmp/testfile_1" + bob <## ("receiving file 1 (testfile) complete, path: " <> testfile1) - src <- B.readFile "./tests/tmp/testfile" - dest <- B.readFile "./tests/tmp/testfile_1" + src <- B.readFile testfile + dest <- B.readFile testfile1 dest `shouldBe` src where cfg = testCfg {xftpDescrPartSize = 200} testAutoAcceptFile :: HasCallStack => TestParams -> IO () testAutoAcceptFile = - testChatOpts2 opts aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do + testChatOpts2 opts aliceProfile bobProfile $ \alice bob -> withXFTPServer alice $ do connectUsers alice bob - bob ##> "/_files_folder ./tests/tmp/bob_files" + bob ##> ("/_files_folder " <> tmpFile bob "bob_files") bob <## "ok" alice #> "/f @bob ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" @@ -1218,7 +1243,7 @@ testAutoAcceptFile = testProhibitFiles :: HasCallStack => TestParams -> IO () testProhibitFiles = - testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> withXFTPServer $ do + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> withXFTPServer alice $ do createGroup3 "team" alice bob cath alice ##> "/set files #team off" alice <## "updated group preferences:" @@ -1240,7 +1265,7 @@ testProhibitFiles = testXFTPStandaloneSmall :: HasCallStack => TestParams -> IO () testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do + withXFTPServer src $ do logNote "sending" src ##> "/_upload 1 ./tests/fixtures/logo.jpg" src <## "started standalone uploading file 1 (logo.jpg)" @@ -1254,7 +1279,7 @@ testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst _uri4 <- getTermLine src logNote "receiving" - let dstFile = "./tests/tmp/logo.jpg" + let dstFile = tmpFile dst "logo.jpg" dst ##> ("/_download 1 " <> uri3 <> " " <> dstFile) dst <## "started standalone receiving file 1 (logo.jpg)" -- silent progress events @@ -1265,7 +1290,7 @@ testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst testXFTPStandaloneSmallInfo :: HasCallStack => TestParams -> IO () testXFTPStandaloneSmallInfo = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do + withXFTPServer src $ do logNote "sending" src ##> "/_upload 1 ./tests/fixtures/logo.jpg" src <## "started standalone uploading file 1 (logo.jpg)" @@ -1284,7 +1309,7 @@ testXFTPStandaloneSmallInfo = testChat2 aliceProfile aliceDesktopProfile $ \src dst <## "{\"secret\":\"*********\"}" logNote "receiving" - let dstFile = "./tests/tmp/logo.jpg" + let dstFile = tmpFile dst "logo.jpg" dst ##> ("/_download 1 " <> uri <> " " <> dstFile) -- download sucessfully discarded extra info dst <## "started standalone receiving file 1 (logo.jpg)" -- silent progress events @@ -1295,11 +1320,12 @@ testXFTPStandaloneSmallInfo = testChat2 aliceProfile aliceDesktopProfile $ \src testXFTPStandaloneLarge :: HasCallStack => TestParams -> IO () testXFTPStandaloneLarge = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + withXFTPServer src $ do + let srcFile = tmpFile src "testfile.in" + xftpCLI ["rand", srcFile, "17mb"] `shouldReturn` ["File created: " <> srcFile] logNote "sending" - src ##> "/_upload 1 ./tests/tmp/testfile.in" + src ##> ("/_upload 1 " <> srcFile) src <## "started standalone uploading file 1 (testfile.in)" -- silent progress events threadDelay 250000 @@ -1311,22 +1337,23 @@ testXFTPStandaloneLarge = testChat2 aliceProfile aliceDesktopProfile $ \src dst _uri4 <- getTermLine src logNote "receiving" - let dstFile = "./tests/tmp/testfile.out" + let dstFile = tmpFile dst "testfile.out" dst ##> ("/_download 1 " <> uri <> " " <> dstFile) dst <## "started standalone receiving file 1 (testfile.out)" -- silent progress events threadDelay 250000 dst <## "completed standalone receiving file 1 (testfile.out)" - srcBody <- B.readFile "./tests/tmp/testfile.in" + srcBody <- B.readFile srcFile B.readFile dstFile `shouldReturn` srcBody testXFTPStandaloneLargeInfo :: HasCallStack => TestParams -> IO () testXFTPStandaloneLargeInfo = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + withXFTPServer src $ do + let srcFile = tmpFile src "testfile.in" + xftpCLI ["rand", srcFile, "17mb"] `shouldReturn` ["File created: " <> srcFile] logNote "sending" - src ##> "/_upload 1 ./tests/tmp/testfile.in" + src ##> ("/_upload 1 " <> srcFile) src <## "started standalone uploading file 1 (testfile.in)" -- silent progress events @@ -1344,22 +1371,23 @@ testXFTPStandaloneLargeInfo = testChat2 aliceProfile aliceDesktopProfile $ \src dst <## "{\"secret\":\"*********\"}" logNote "receiving" - let dstFile = "./tests/tmp/testfile.out" + let dstFile = tmpFile dst "testfile.out" dst ##> ("/_download 1 " <> uri <> " " <> dstFile) dst <## "started standalone receiving file 1 (testfile.out)" -- silent progress events threadDelay 250000 dst <## "completed standalone receiving file 1 (testfile.out)" - srcBody <- B.readFile "./tests/tmp/testfile.in" + srcBody <- B.readFile srcFile B.readFile dstFile `shouldReturn` srcBody testXFTPStandaloneCancelSnd :: HasCallStack => TestParams -> IO () testXFTPStandaloneCancelSnd = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + withXFTPServer src $ do + let srcFile = tmpFile src "testfile.in" + xftpCLI ["rand", srcFile, "17mb"] `shouldReturn` ["File created: " <> srcFile] logNote "sending" - src ##> "/_upload 1 ./tests/tmp/testfile.in" + src ##> ("/_upload 1 " <> srcFile) src <## "started standalone uploading file 1 (testfile.in)" -- silent progress events threadDelay 250000 @@ -1376,7 +1404,7 @@ testXFTPStandaloneCancelSnd = testChat2 aliceProfile aliceDesktopProfile $ \src threadDelay 1000000 logNote "trying to receive cancelled" - dst ##> ("/_download 1 " <> uri <> " " <> "./tests/tmp/should.not.extist") + dst ##> ("/_download 1 " <> uri <> " " <> tmpFile dst "should.not.extist") dst <## "started standalone receiving file 1 (should.not.extist)" threadDelay 100000 logWarn "no error?" @@ -1385,12 +1413,14 @@ testXFTPStandaloneCancelSnd = testChat2 aliceProfile aliceDesktopProfile $ \src testXFTPStandaloneRelativePaths :: HasCallStack => TestParams -> IO () testXFTPStandaloneRelativePaths = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do + withXFTPServer src $ do logNote "sending" - src #$> ("/_files_folder ./tests/tmp/src_files", id, "ok") - src #$> ("/_temp_folder ./tests/tmp/src_xftp_temp", id, "ok") + let srcFiles = tmpFile src "src_files" + dstFiles = tmpFile dst "dst_files" + src #$> ("/_files_folder " <> srcFiles, id, "ok") + src #$> ("/_temp_folder " <> tmpFile src "src_xftp_temp", id, "ok") - xftpCLI ["rand", "./tests/tmp/src_files/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/src_files/testfile.in"] + xftpCLI ["rand", srcFiles "testfile.in", "17mb"] `shouldReturn` ["File created: " <> (srcFiles "testfile.in")] src ##> "/_upload 1 testfile.in" src <## "started standalone uploading file 1 (testfile.in)" @@ -1404,23 +1434,24 @@ testXFTPStandaloneRelativePaths = testChat2 aliceProfile aliceDesktopProfile $ \ _uri4 <- getTermLine src logNote "receiving" - dst #$> ("/_files_folder ./tests/tmp/dst_files", id, "ok") - dst #$> ("/_temp_folder ./tests/tmp/dst_xftp_temp", id, "ok") + dst #$> ("/_files_folder " <> dstFiles, id, "ok") + dst #$> ("/_temp_folder " <> tmpFile dst "dst_xftp_temp", id, "ok") dst ##> ("/_download 1 " <> uri <> " testfile.out") dst <## "started standalone receiving file 1 (testfile.out)" -- silent progress events threadDelay 250000 dst <## "completed standalone receiving file 1 (testfile.out)" - srcBody <- B.readFile "./tests/tmp/src_files/testfile.in" - B.readFile "./tests/tmp/dst_files/testfile.out" `shouldReturn` srcBody + srcBody <- B.readFile (srcFiles "testfile.in") + B.readFile (dstFiles "testfile.out") `shouldReturn` srcBody testXFTPStandaloneCancelRcv :: HasCallStack => TestParams -> IO () testXFTPStandaloneCancelRcv = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do - withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + withXFTPServer src $ do + let srcFile = tmpFile src "testfile.in" + xftpCLI ["rand", srcFile, "17mb"] `shouldReturn` ["File created: " <> srcFile] logNote "sending" - src ##> "/_upload 1 ./tests/tmp/testfile.in" + src ##> ("/_upload 1 " <> srcFile) src <## "started standalone uploading file 1 (testfile.in)" -- silent progress events threadDelay 250000 @@ -1432,7 +1463,7 @@ testXFTPStandaloneCancelRcv = testChat2 aliceProfile aliceDesktopProfile $ \src _uri4 <- getTermLine src logNote "receiving" - let dstFile = "./tests/tmp/testfile.out" + let dstFile = tmpFile dst "testfile.out" dst ##> ("/_download 1 " <> uri <> " " <> dstFile) dst <## "started standalone receiving file 1 (testfile.out)" threadDelay 25000 -- give workers some time to avoid internal errors from starting tasks diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs index 1654ce5335..a5de4d2c37 100644 --- a/tests/ChatTests/Forward.hs +++ b/tests/ChatTests/Forward.hs @@ -15,6 +15,7 @@ import qualified Data.Text as T import Simplex.Chat.Library.Commands (fixedImagePreview) import Simplex.Chat.Types (ImageData (..)) import System.Directory (copyFile, doesFileExist, removeFile) +import System.FilePath (()) import Test.Hspec hiding (it) chatForwardTests :: SpecWith TestParams @@ -500,7 +501,7 @@ testForwardDeleteForOther = testForwardFileNoFilesFolder :: HasCallStack => TestParams -> IO () testForwardFileNoFilesFolder = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do connectUsers alice bob connectUsers bob cath @@ -513,51 +514,51 @@ testForwardFileNoFilesFolder = bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob ##> "/fr 1 ./tests/tmp" + bob ##> ("/fr 1 " <> tmpDir bob) concurrentlyN_ [ alice <## "completed uploading file 1 (test.pdf) for bob", bob - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile bob "test.pdf", "started receiving file 1 (test.pdf) from alice" ] ] bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile bob "test.pdf") dest `shouldBe` src -- forward file bob `send` "@cath <- @alice hi" bob <# "@cath <- @alice" bob <## " hi" - bob <# "/f @cath ./tests/tmp/test.pdf" + bob <# ("/f @cath " <> tmpFile bob "test.pdf") bob <## "use /fc 2 to cancel sending" cath <# "bob> -> forwarded" cath <## " hi" cath <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)" cath <## "use /fr 1 [/ | ] to receive it" - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) concurrentlyN_ [ bob <## "completed uploading file 2 (test.pdf) for cath", cath - <### [ "saving file 1 from bob to ./tests/tmp/test_1.pdf", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "test_1.pdf", "started receiving file 1 (test.pdf) from bob" ] ] cath <## "completed receiving file 1 (test.pdf) from bob" - dest2 <- B.readFile "./tests/tmp/test_1.pdf" + dest2 <- B.readFile (tmpFile cath "test_1.pdf") dest2 `shouldBe` src testForwardFileContactToContact :: HasCallStack => TestParams -> IO () testForwardFileContactToContact = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" - setRelativePaths bob "./tests/tmp/bob_files" "./tests/tmp/bob_xftp" - setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" + \alice bob cath -> withXFTPServer alice $ do + setRelativePaths alice "./tests/fixtures" (tmpFile alice "alice_xftp") + setRelativePaths bob (tmpFile bob "bob_files") (tmpFile bob "bob_xftp") + setRelativePaths cath (tmpFile cath "cath_files") (tmpFile cath "cath_xftp") connectUsers alice bob connectUsers bob cath @@ -581,7 +582,7 @@ testForwardFileContactToContact = bob <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/bob_files/test.pdf" + dest <- B.readFile (tmpFile bob "bob_files/test.pdf") dest `shouldBe` src -- forward file @@ -605,24 +606,24 @@ testForwardFileContactToContact = ] cath <## "completed receiving file 1 (test_1.pdf) from bob" - src2 <- B.readFile "./tests/tmp/bob_files/test_1.pdf" + src2 <- B.readFile (tmpFile bob "bob_files/test_1.pdf") src2 `shouldBe` dest - dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 <- B.readFile (tmpFile cath "cath_files/test_1.pdf") dest2 `shouldBe` src2 -- deleting original file doesn't delete forwarded file - checkActionDeletesFile "./tests/tmp/bob_files/test.pdf" $ do + checkActionDeletesFile (tmpFile bob "bob_files/test.pdf") $ do bob ##> "/clear alice" bob <## "alice: all messages are removed locally ONLY" - fwdFileExists <- doesFileExist "./tests/tmp/bob_files/test_1.pdf" + fwdFileExists <- doesFileExist (tmpFile bob "bob_files/test_1.pdf") fwdFileExists `shouldBe` True testForwardFileGroupToNotes :: HasCallStack => TestParams -> IO () testForwardFileGroupToNotes = testChat2 aliceProfile cathProfile $ - \alice cath -> withXFTPServer $ do - setRelativePaths alice "./tests/fixtures" "./tests/tmp/alice_xftp" - setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" + \alice cath -> withXFTPServer alice $ do + setRelativePaths alice "./tests/fixtures" (tmpFile alice "alice_xftp") + setRelativePaths cath (tmpFile cath "cath_files") (tmpFile cath "cath_xftp") createGroup2 "team" alice cath createCCNoteFolder cath @@ -646,7 +647,7 @@ testForwardFileGroupToNotes = cath <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/cath_files/test.pdf" + dest <- B.readFile (tmpFile cath "cath_files/test.pdf") dest `shouldBe` src -- forward file @@ -655,23 +656,23 @@ testForwardFileGroupToNotes = cath <## " hi" cath <# "* file 2 (test_1.pdf)" - dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 <- B.readFile (tmpFile cath "cath_files/test_1.pdf") dest2 `shouldBe` dest -- deleting original file doesn't delete forwarded file - checkActionDeletesFile "./tests/tmp/cath_files/test.pdf" $ do + checkActionDeletesFile (tmpFile cath "cath_files/test.pdf") $ do cath ##> "/clear #team" cath <## "#team: all messages are removed locally ONLY" - fwdFileExists <- doesFileExist "./tests/tmp/cath_files/test_1.pdf" + fwdFileExists <- doesFileExist (tmpFile cath "cath_files/test_1.pdf") fwdFileExists `shouldBe` True testForwardFileNotesToGroup :: HasCallStack => TestParams -> IO () testForwardFileNotesToGroup = testChat2 aliceProfile cathProfile $ - \alice cath -> withXFTPServer $ do - setRelativePaths alice "./tests/tmp/alice_files" "./tests/tmp/alice_xftp" - setRelativePaths cath "./tests/tmp/cath_files" "./tests/tmp/cath_xftp" - copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_files/test.pdf" + \alice cath -> withXFTPServer alice $ do + setRelativePaths alice (tmpFile alice "alice_files") (tmpFile alice "alice_xftp") + setRelativePaths cath (tmpFile cath "cath_files") (tmpFile cath "cath_xftp") + copyFile "./tests/fixtures/test.pdf" (tmpFile alice "alice_files/test.pdf") createCCNoteFolder alice createGroup2 "team" alice cath @@ -699,17 +700,17 @@ testForwardFileNotesToGroup = ] cath <## "completed receiving file 1 (test_1.pdf) from alice" - src <- B.readFile "./tests/tmp/alice_files/test.pdf" - src2 <- B.readFile "./tests/tmp/alice_files/test_1.pdf" + src <- B.readFile (tmpFile alice "alice_files/test.pdf") + src2 <- B.readFile (tmpFile alice "alice_files/test_1.pdf") src2 `shouldBe` src - dest2 <- B.readFile "./tests/tmp/cath_files/test_1.pdf" + dest2 <- B.readFile (tmpFile cath "cath_files/test_1.pdf") dest2 `shouldBe` src2 -- deleting original file doesn't delete forwarded file - checkActionDeletesFile "./tests/tmp/alice_files/test.pdf" $ do + checkActionDeletesFile (tmpFile alice "alice_files/test.pdf") $ do alice ##> "/clear *" alice <## "notes: all messages are removed" - fwdFileExists <- doesFileExist "./tests/tmp/alice_files/test_1.pdf" + fwdFileExists <- doesFileExist (tmpFile alice "alice_files/test_1.pdf") fwdFileExists `shouldBe` True testForwardContactToContactMulti :: HasCallStack => TestParams -> IO () @@ -789,14 +790,17 @@ testForwardGroupToGroupMulti = testMultiForwardFiles :: HasCallStack => TestParams -> IO () testMultiForwardFiles = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - setRelativePaths alice "./tests/tmp/alice_app_files" "./tests/tmp/alice_xftp" - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" - copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf" - copyFile "./tests/fixtures/test_1MB.pdf" "./tests/tmp/alice_app_files/test_1MB.pdf" - copyFile "./tests/fixtures/logo.jpg" "./tests/tmp/alice_app_files/logo.jpg" - setRelativePaths bob "./tests/tmp/bob_app_files" "./tests/tmp/bob_xftp" - setRelativePaths cath "./tests/tmp/cath_app_files" "./tests/tmp/cath_xftp" + \alice bob cath -> withXFTPServer alice $ do + let aliceFiles = tmpFile alice "alice_app_files" + bobFiles = tmpFile bob "bob_app_files" + cathFiles = tmpFile cath "cath_app_files" + setRelativePaths alice aliceFiles (tmpFile alice "alice_xftp") + copyFile "./tests/fixtures/test.jpg" (aliceFiles "test.jpg") + copyFile "./tests/fixtures/test.pdf" (aliceFiles "test.pdf") + copyFile "./tests/fixtures/test_1MB.pdf" (aliceFiles "test_1MB.pdf") + copyFile "./tests/fixtures/logo.jpg" (aliceFiles "logo.jpg") + setRelativePaths bob bobFiles (tmpFile bob "bob_xftp") + setRelativePaths cath cathFiles (tmpFile cath "cath_xftp") connectUsers alice bob connectUsers bob cath @@ -876,12 +880,12 @@ testMultiForwardFiles = ] bob <## "completed receiving file 2 (test.pdf) from alice" - src1 <- B.readFile "./tests/tmp/alice_app_files/test.jpg" - dest1 <- B.readFile "./tests/tmp/bob_app_files/test.jpg" + src1 <- B.readFile (aliceFiles "test.jpg") + dest1 <- B.readFile (bobFiles "test.jpg") dest1 `shouldBe` src1 - src2 <- B.readFile "./tests/tmp/alice_app_files/test.pdf" - dest2 <- B.readFile "./tests/tmp/bob_app_files/test.pdf" + src2 <- B.readFile (aliceFiles "test.pdf") + dest2 <- B.readFile (bobFiles "test.pdf") dest2 `shouldBe` src2 -- forward file @@ -955,14 +959,14 @@ testMultiForwardFiles = ] cath <## "completed receiving file 2 (test_1.pdf) from bob" - src1B <- B.readFile ("./tests/tmp/bob_app_files/" <> jpgFileName) + src1B <- B.readFile (bobFiles jpgFileName) src1B `shouldBe` dest1 - dest1C <- B.readFile ("./tests/tmp/cath_app_files/" <> jpgFileName) + dest1C <- B.readFile (cathFiles jpgFileName) dest1C `shouldBe` src1B - src2B <- B.readFile "./tests/tmp/bob_app_files/test_1.pdf" + src2B <- B.readFile (bobFiles "test_1.pdf") src2B `shouldBe` dest2 - dest2C <- B.readFile "./tests/tmp/cath_app_files/test_1.pdf" + dest2C <- B.readFile (cathFiles "test_1.pdf") dest2C `shouldBe` src2B bob ##> "/fr 3" @@ -986,19 +990,19 @@ testMultiForwardFiles = bob ##> ("/_forward plan @2 " <> msgIds) bob <## "all messages can be forwarded" - removeFile "./tests/tmp/bob_app_files/test_1MB.pdf" + removeFile (bobFiles "test_1MB.pdf") bob ##> ("/_forward plan @2 " <> msgIds) bob <## "1 file(s) are missing" bob <## "all messages can be forwarded" - removeFile "./tests/tmp/bob_app_files/test.pdf" + removeFile (bobFiles "test.pdf") bob ##> ("/_forward plan @2 " <> msgIds) bob <## "2 file(s) are missing" bob <## "5 message(s) out of 6 can be forwarded" -- deleting original file doesn't delete forwarded file - checkActionDeletesFile "./tests/tmp/bob_app_files/test.jpg" $ do + checkActionDeletesFile (bobFiles "test.jpg") $ do bob ##> "/clear alice" bob <## "alice: all messages are removed locally ONLY" - fwdFileExists <- doesFileExist ("./tests/tmp/bob_app_files/" <> jpgFileName) + fwdFileExists <- doesFileExist (bobFiles jpgFileName) fwdFileExists `shouldBe` True diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 0cc697b012..39e50dc16b 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -2003,7 +2003,7 @@ testGroupDelayedModerationFullDelete ps = do testDeleteMemberWithMessages :: HasCallStack => TestParams -> IO () testDeleteMemberWithMessages = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup3' "team" alice (bob, GRMember) (cath, GRMember) threadDelay 750000 alice ##> "/set delete #team on" @@ -2022,10 +2022,13 @@ testDeleteMemberWithMessages = ] threadDelay 750000 - alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") - bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") - cath #$> ("/_files_folder ./tests/tmp/cath_app_files", id, "ok") - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/bob_app_files/test.jpg" + let aliceFiles = tmpFile alice "alice_app_files" + bobFiles = tmpFile bob "bob_app_files" + cathFiles = tmpFile cath "cath_app_files" + alice #$> ("/_files_folder " <> aliceFiles, id, "ok") + bob #$> ("/_files_folder " <> bobFiles, id, "ok") + cath #$> ("/_files_folder " <> cathFiles, id, "ok") + copyFile "./tests/fixtures/test.jpg" (bobFiles "test.jpg") bob ##> "/_send #1 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"file from bob\"}}]" bob <# "#team file from bob" @@ -2057,9 +2060,9 @@ testDeleteMemberWithMessages = cath <## "completed receiving file 1 (test.jpg) from bob" src <- B.readFile "./tests/fixtures/test.jpg" - B.readFile "./tests/tmp/alice_app_files/test.jpg" `shouldReturn` src - B.readFile "./tests/tmp/bob_app_files/test.jpg" `shouldReturn` src - B.readFile "./tests/tmp/cath_app_files/test.jpg" `shouldReturn` src + B.readFile (aliceFiles "test.jpg") `shouldReturn` src + B.readFile (bobFiles "test.jpg") `shouldReturn` src + B.readFile (cathFiles "test.jpg") `shouldReturn` src threadDelay 1000000 alice ##> "/rm #team bob messages=on" @@ -2068,9 +2071,9 @@ testDeleteMemberWithMessages = bob <## "use /d #team to delete the group" cath <## "#team: alice removed bob from the group with all messages (signed)" - doesFileExist "./tests/tmp/alice_app_files/test.jpg" `shouldReturn` False - doesFileExist "./tests/tmp/bob_app_files/test.jpg" `shouldReturn` False - doesFileExist "./tests/tmp/cath_app_files/test.jpg" `shouldReturn` False + doesFileExist (aliceFiles "test.jpg") `shouldReturn` False + doesFileExist (bobFiles "test.jpg") `shouldReturn` False + doesFileExist (cathFiles "test.jpg") `shouldReturn` False -- Under fullDelete, bob's items are physically deleted on all sides; only the system event remains. alice #$> ("/_get chat #1 count=1", chat, [(1, "removed bob (signed)")]) @@ -2253,11 +2256,15 @@ testSharedMessageBody ps' = withTestChatOpts ps opts' "cath" $ \cath -> do concurrentlyN_ [ alice <## "subscribed 4 connections on server localhost", - bob <## "subscribed 3 connections on server localhost", - cath <## "subscribed 3 connections on server localhost" + bob + <### [ "subscribed 3 connections on server localhost", + WithTime "#team alice> hello" + ], + cath + <### [ "subscribed 3 connections on server localhost", + WithTime "#team alice> hello" + ] ] - bob <# "#team alice> hello" - cath <# "#team alice> hello" threadDelay 500000 checkMsgBodyCount alice 0 @@ -2266,8 +2273,8 @@ testSharedMessageBody ps' = ps = ps' {printOutput = True} :: TestParams tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -2320,8 +2327,8 @@ testSharedBatchBody ps = where tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -2525,8 +2532,8 @@ testSharedBatchBodyMixed ps = oldCfg = testCfg {chatVRange = mkVersionRange (VersionChat 9) (VersionChat 17)} tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -2931,10 +2938,10 @@ testPlanGroupLinkOwn ps = alice <## "group link: own link for group #team" alice ##> ("/c " <> gLink) - alice <## "connection request sent!" - alice <## "alice_1 (Alice): accepting request to join group #team..." alice - <### [ "#team: alice_1 joined the group", + <### [ "connection request sent!", + "alice_1 (Alice): accepting request to join group #team...", + "#team: alice_1 joined the group", "#team_1: joining the group...", "#team_1: you joined the group" ] @@ -3319,7 +3326,7 @@ testGroupLinkMemberRole = bob <## "#team: you joined the group" ] - threadDelay 250000 + getProfileShortDescrByName bob "alice" `shouldEventuallyReturn` Just "Alice" alice ##> "/ms team" alice @@ -3489,10 +3496,7 @@ testGroupLinkHostProfileReceived = bob <## "#team: you joined the group" ] - threadDelay 250000 - - aliceImage <- getProfilePictureByName bob "alice" - aliceImage `shouldBe` Just profileImage + getProfilePictureByName bob "alice" `shouldEventuallyReturn` Just profileImage testGroupLinkExistingContactMerged :: HasCallStack => TestParams -> IO () testGroupLinkExistingContactMerged = @@ -3553,12 +3557,8 @@ testGLinkRejectBlockedName = bob <## "#team: joining the group..." bob <## "#team: join rejected, reason: GRRBlockedName" - threadDelay 100000 - + withCCTransaction alice (\db -> DB.query_ db "SELECT count(1) FROM group_members" :: IO [[Int]]) `shouldEventuallyReturn` [[1]] alice `hasContactProfiles` ["alice"] - memCount <- withCCTransaction alice $ \db -> - DB.query_ db "SELECT count(1) FROM group_members" :: IO [[Int]] - memCount `shouldBe` [[1]] -- rejected member can't send messages to group bob ##> "#team hello" @@ -4116,10 +4116,13 @@ testPlanGroupLinkConnecting ps = do <### [ "subscribed 1 connections on server localhost", "bob (Bob): accepting request to join group #team..." ] + withCCAgentTransaction alice (\db -> DB.query_ db "SELECT count(1) FROM commands" :: IO [[Int]]) `shouldEventuallyReturn` [[0]] withTestChat ps "bob" $ \bob -> do threadDelay 500000 - bob <## "subscribed 1 connections on server localhost" - bob <## "#team: joining the group..." + bob + <### [ "subscribed 1 connections on server localhost", + "#team: joining the group..." + ] bob <## "#team: you joined the group" bob ##> ("/_connect plan 1 " <> gLink) @@ -4214,8 +4217,8 @@ testGroupSyncRatchet ps = bob <## "#team alice: connection synchronized" threadDelay 100000 - bob #$> ("/_get chat #1 count=3", chat, [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "connection synchronized")]) - alice #$> ("/_get chat #1 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")]) + (bob ##> "/_get chat #1 count=3" >> chat <$> getTermLine bob) `shouldEventuallyReturn` [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "connection synchronized")] + (alice ##> "/_get chat #1 count=2" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(0, "connection synchronization agreed"), (0, "connection synchronized")] alice #> "#team hello again" bob <# "#team alice> hello again" @@ -4254,8 +4257,8 @@ testGroupSyncRatchetCodeReset ps = bob <## "#team alice: connection synchronized" threadDelay 100000 - bob #$> ("/_get chat #1 count=4", chat, [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")]) - alice #$> ("/_get chat #1 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")]) + (bob ##> "/_get chat #1 count=4" >> chat <$> getTermLine bob) `shouldEventuallyReturn` [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")] + (alice ##> "/_get chat #1 count=2" >> chat <$> getTermLine alice) `shouldEventuallyReturn` [(0, "connection synchronization agreed"), (0, "connection synchronized")] -- connection not verified bob ##> "/i #team alice" @@ -4748,13 +4751,13 @@ testMergeGroupLinkHostMultipleContacts = concurrentlyN_ [ bob <### [ EndsWith "joined the group", - "contact and member are merged: cath, #party cath_2", + Predicate (`elem` ["contact and member are merged: cath, #party cath_2", "contact and member are merged: cath_1, #party cath_2"]), StartsWith "use @cath" ], cath <### [ "#party: joining the group...", "#party: you joined the group", - "contact and member are merged: bob, #party bob_2", + Predicate (`elem` ["contact and member are merged: bob, #party bob_2", "contact and member are merged: bob_1, #party bob_2"]), StartsWith "use @bob" ] ] @@ -4809,8 +4812,10 @@ testMemberContactMessage = alice <##> bob alice `send` "@bob hi" - alice <## "bob: quantum resistant end-to-end encryption enabled" - alice <# "@bob hi" + alice + <### [ "bob: quantum resistant end-to-end encryption enabled", + WithTime "@bob hi" + ] bob <## "alice: quantum resistant end-to-end encryption enabled" bob <# "alice> hi" @@ -5539,8 +5544,16 @@ setupGroupForwardingVectors :: TestCC -> TestCC -> TestCC -> IO () setupGroupForwardingVectors host invitee1 invitee2 = do invitee1Name <- userName invitee1 invitee2Name <- userName invitee2 + groupForwardingRelations host invitee1Name invitee2Name `shouldEventuallyReturn` (MRConnected, MRConnected) updateGroupForwardingVectors host invitee1Name invitee2Name MRIntroduced +groupForwardingRelations :: TestCC -> String -> String -> IO (MemberRelation, MemberRelation) +groupForwardingRelations host invitee1Name invitee2Name = + withCCTransaction host $ \db -> do + [(invitee1Index, invitee1Vec)] <- DB.query db "SELECT index_in_group, member_relations_vector FROM group_members WHERE local_display_name = ?" (Only invitee1Name) + [(invitee2Index, invitee2Vec)] <- DB.query db "SELECT index_in_group, member_relations_vector FROM group_members WHERE local_display_name = ?" (Only invitee2Name) + pure (getRelation invitee2Index (fromMaybe B.empty invitee1Vec), getRelation invitee1Index (fromMaybe B.empty invitee2Vec)) + updateGroupForwardingVectors :: TestCC -> String -> String -> MemberRelation -> IO () updateGroupForwardingVectors host invitee1Name invitee2Name relation = do void $ withCCTransaction host $ \db -> do @@ -5675,7 +5688,7 @@ testGroupMsgForwardDeletion = testGroupMsgForwardFile :: HasCallStack => TestParams -> IO () testGroupMsgForwardFile = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup3 "team" alice bob cath setupGroupForwarding alice bob cath @@ -5690,12 +5703,14 @@ testGroupMsgForwardFile = cath <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" cath <## "use /fr 1 [/ | ] to receive it [>>]" ] - cath ##> "/fr 1 ./tests/tmp" - cath <## "saving file 1 from bob to ./tests/tmp/test.jpg" - cath <## "started receiving file 1 (test.jpg) from bob" + cath ##> ("/fr 1 " <> tmpDir cath) + cath + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "test.jpg", + "started receiving file 1 (test.jpg) from bob" + ] cath <## "completed receiving file 1 (test.jpg) from bob" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile (tmpFile cath "test.jpg") dest `shouldBe` src testGroupMsgForwardChangeRole :: HasCallStack => TestParams -> IO () @@ -6047,7 +6062,7 @@ testGroupHistoryPreferenceOff = testGroupHistoryHostFile :: HasCallStack => TestParams -> IO () testGroupHistoryHostFile = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup2 "team" alice bob alice #> "/f #team ./tests/fixtures/test.jpg" @@ -6073,20 +6088,20 @@ testGroupHistoryHostFile = bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile cath "test.jpg", "started receiving file 1 (test.jpg) from alice" ] cath <## "completed receiving file 1 (test.jpg) from alice" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile (tmpFile cath "test.jpg") dest `shouldBe` src testGroupHistoryMemberFile :: HasCallStack => TestParams -> IO () testGroupHistoryMemberFile = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup2 "team" alice bob bob #> "/f #team ./tests/fixtures/test.jpg" @@ -6112,27 +6127,28 @@ testGroupHistoryMemberFile = bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from bob to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "test.jpg", "started receiving file 1 (test.jpg) from bob" ] cath <## "completed receiving file 1 (test.jpg) from bob" src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile (tmpFile cath "test.jpg") dest `shouldBe` src testGroupHistoryLargeFile :: HasCallStack => TestParams -> IO () testGroupHistoryLargeFile = testChatCfg3 cfg aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile"] + \alice bob cath -> withXFTPServer alice $ do + let testfile = tmpFile bob "testfile" + xftpCLI ["rand", testfile, "17mb"] `shouldReturn` ["File created: " <> testfile] createGroup2 "team" alice bob - bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}]" + bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfile <> "\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}]") bob <# "#team hello" - bob <# "/f #team ./tests/tmp/testfile" + bob <# ("/f #team " <> testfile) bob <## "use /fc 1 to cancel sending" bob <## "completed uploading file 1 (testfile) for #team" @@ -6141,14 +6157,14 @@ testGroupHistoryLargeFile = alice <## "use /fr 1 [/ | ] to receive it" -- admin receiving file does not prevent the new member from receiving it later - alice ##> "/fr 1 ./tests/tmp" + alice ##> ("/fr 1 " <> tmpDir alice) alice - <### [ "saving file 1 from bob to ./tests/tmp/testfile_1", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile alice "testfile_1", "started receiving file 1 (testfile) from bob" ] alice <## "completed receiving file 1 (testfile) from bob" - src <- B.readFile "./tests/tmp/testfile" - destAlice <- B.readFile "./tests/tmp/testfile_1" + src <- B.readFile testfile + destAlice <- B.readFile (tmpFile alice "testfile_1") destAlice `shouldBe` src connectUsers alice cath @@ -6168,14 +6184,14 @@ testGroupHistoryLargeFile = bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from bob to ./tests/tmp/testfile_2", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "testfile_2", "started receiving file 1 (testfile) from bob" ] cath <## "completed receiving file 1 (testfile) from bob" - destCath <- B.readFile "./tests/tmp/testfile_2" + destCath <- B.readFile (tmpFile cath "testfile_2") destCath `shouldBe` src where cfg = testCfg {xftpDescrPartSize = 200} @@ -6183,17 +6199,19 @@ testGroupHistoryLargeFile = testGroupHistoryMultipleFiles :: HasCallStack => TestParams -> IO () testGroupHistoryMultipleFiles = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"] - xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"] + \alice bob cath -> withXFTPServer alice $ do + let testfileBob = tmpFile bob "testfile_bob" + testfileAlice = tmpFile alice "testfile_alice" + xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob] + xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice] createGroup2 "team" alice bob threadDelay 1000000 - bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]" + bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfileBob <> "\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]") bob <# "#team hi alice" - bob <# "/f #team ./tests/tmp/testfile_bob" + bob <# ("/f #team " <> testfileBob) bob <## "use /fc 1 to cancel sending" bob <## "completed uploading file 1 (testfile_bob) for #team" @@ -6203,9 +6221,9 @@ testGroupHistoryMultipleFiles = threadDelay 1000000 - alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]" + alice ##> ("/_send #1 json [{\"filePath\": \"" <> testfileAlice <> "\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]") alice <# "#team hey bob" - alice <# "/f #team ./tests/tmp/testfile_alice" + alice <# ("/f #team " <> testfileAlice) alice <## "use /fc 2 to cancel sending" alice <## "completed uploading file 2 (testfile_alice) for #team" @@ -6233,45 +6251,47 @@ testGroupHistoryMultipleFiles = bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir cath) cath - <### [ "saving file 1 from bob to ./tests/tmp/testfile_bob_1", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "testfile_bob_1", "started receiving file 1 (testfile_bob) from bob" ] cath <## "completed receiving file 1 (testfile_bob) from bob" - srcBob <- B.readFile "./tests/tmp/testfile_bob" - destBob <- B.readFile "./tests/tmp/testfile_bob_1" + srcBob <- B.readFile testfileBob + destBob <- B.readFile (tmpFile cath "testfile_bob_1") destBob `shouldBe` srcBob - cath ##> "/fr 2 ./tests/tmp" + cath ##> ("/fr 2 " <> tmpDir cath) cath - <### [ "saving file 2 from alice to ./tests/tmp/testfile_alice_1", + <### [ ConsoleString $ "saving file 2 from alice to " <> tmpFile cath "testfile_alice_1", "started receiving file 2 (testfile_alice) from alice" ] cath <## "completed receiving file 2 (testfile_alice) from alice" - srcAlice <- B.readFile "./tests/tmp/testfile_alice" - destAlice <- B.readFile "./tests/tmp/testfile_alice_1" + srcAlice <- B.readFile testfileAlice + destAlice <- B.readFile (tmpFile cath "testfile_alice_1") destAlice `shouldBe` srcAlice cath ##> "/_get chat #1 count=100" r <- chatF <$> getTermLine cath r - `shouldContain` [ ((0, "hi alice"), Just "./tests/tmp/testfile_bob_1"), - ((0, "hey bob"), Just "./tests/tmp/testfile_alice_1") + `shouldContain` [ ((0, "hi alice"), Just $ tmpFile cath "testfile_bob_1"), + ((0, "hey bob"), Just $ tmpFile cath "testfile_alice_1") ] testGroupHistoryFileCancel :: HasCallStack => TestParams -> IO () testGroupHistoryFileCancel = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"] - xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"] + \alice bob cath -> withXFTPServer alice $ do + let testfileBob = tmpFile bob "testfile_bob" + testfileAlice = tmpFile alice "testfile_alice" + xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob] + xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice] createGroup2 "team" alice bob - bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]" + bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfileBob <> "\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]") bob <# "#team hi alice" - bob <# "/f #team ./tests/tmp/testfile_bob" + bob <# ("/f #team " <> testfileBob) bob <## "use /fc 1 to cancel sending" bob <## "completed uploading file 1 (testfile_bob) for #team" @@ -6285,9 +6305,9 @@ testGroupHistoryFileCancel = threadDelay 1000000 - alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]" + alice ##> ("/_send #1 json [{\"filePath\": \"" <> testfileAlice <> "\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]") alice <# "#team hey bob" - alice <# "/f #team ./tests/tmp/testfile_alice" + alice <# ("/f #team " <> testfileAlice) alice <## "use /fc 2 to cancel sending" alice <## "completed uploading file 2 (testfile_alice) for #team" @@ -6318,9 +6338,11 @@ testGroupHistoryFileCancel = testGroupHistoryFileCancelNoText :: HasCallStack => TestParams -> IO () testGroupHistoryFileCancelNoText = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"] - xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"] + \alice bob cath -> withXFTPServer alice $ do + let testfileBob = tmpFile bob "testfile_bob" + testfileAlice = tmpFile alice "testfile_alice" + xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob] + xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice] createGroup2 "team" alice bob @@ -6329,7 +6351,7 @@ testGroupHistoryFileCancelNoText = -- bob file - bob #> "/f #team ./tests/tmp/testfile_bob" + bob #> ("/f #team " <> testfileBob) bob <## "use /fc 1 to cancel sending" bob <## "completed uploading file 1 (testfile_bob) for #team" @@ -6342,7 +6364,7 @@ testGroupHistoryFileCancelNoText = -- alice file - alice #> "/f #team ./tests/tmp/testfile_alice" + alice #> ("/f #team " <> testfileAlice) alice <## "use /fc 2 to cancel sending" alice <## "completed uploading file 2 (testfile_alice) for #team" @@ -6533,12 +6555,12 @@ testGroupHistoryDisappearingMessage = threadDelay 1000000 -- 3 seconds so that messages 2 and 3 are not deleted for alice before sending history to cath - alice ##> "/set disappear #team on 4" + alice ##> "/set disappear #team on 15" alice <## "updated group preferences:" - alice <## "Disappearing messages: on (4 sec)" + alice <## "Disappearing messages: on (15 sec)" bob <## "alice updated group #team: (signed)" bob <## "updated group preferences:" - bob <## "Disappearing messages: on (4 sec)" + bob <## "Disappearing messages: on (15 sec)" bob #> "#team 2" alice <# "#team bob> 2" @@ -6582,6 +6604,7 @@ testGroupHistoryDisappearingMessage = r1 <- chat <$> getTermLine cath r1 `shouldContain` [(0, "1"), (0, "2"), (0, "3"), (0, "4")] + threadDelay 11000000 concurrentlyN_ [ alice <### [ "timed message deleted: 2", @@ -7665,6 +7688,7 @@ testGroupMemberInactive ps = do bob <# "#team alice> hi" bob #> "#team hey" alice <# "#team bob> hey" + threadDelay 1000000 -- bob is offline alice #> "#team 1" @@ -7682,8 +7706,10 @@ testGroupMemberInactive ps = do threadDelay 1500000 withTestChatCfgOpts ps cfg' opts' "bob" $ \bob -> do - bob <## "subscribed 2 connections on server localhost" - bob <# "#team alice> 1" + bob + <### [ "subscribed 2 connections on server localhost", + WithTime "#team alice> 1" + ] bob <# "#team alice> 2" bob <#. "#team alice> skipped message ID" alice <## "[#team bob] inactive connection is marked as active" @@ -7702,8 +7728,8 @@ testGroupMemberInactive ps = do alice <# "#team bob> hey" where serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], msgQueueQuota = 2 } fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} -- same as in agent tests @@ -7786,9 +7812,10 @@ testGroupMemberReports = dan #$> ("/_get chat #1 content=report count=100", chat, [(1, "report content")]) alice ##> "\\\\ #jokes cath inappropriate joke" concurrentlyN_ - [ do - alice <## "#jokes: 1 messages deleted by user" - alice <## "message marked deleted by you", + [ alice + <### [ "#jokes: 1 messages deleted by user", + "message marked deleted by you" + ], do bob <# "#jokes cath> [marked deleted by alice] inappropriate joke" bob <## "#jokes: 1 messages deleted by member alice", @@ -8356,7 +8383,7 @@ testScopedSupportDontForwardBetweenScopes = testScopedSupportForwardFile :: HasCallStack => TestParams -> IO () testScopedSupportForwardFile = - testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> withXFTPServer $ do + testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> withXFTPServer alice $ do createGroup4 "team" alice (bob, GRMember) (cath, GRMember) (dan, GRModerator) setupGroupForwarding alice bob dan @@ -8379,9 +8406,9 @@ testScopedSupportForwardFile = bob <## "completed uploading file 1 (test.jpg) for #team" - dan ##> "/fr 1 ./tests/tmp" + dan ##> ("/fr 1 " <> tmpDir dan) dan - <### [ "saving file 1 from bob to ./tests/tmp/test.jpg", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile dan "test.jpg", "started receiving file 1 (test.jpg) from bob" ] dan <## "completed receiving file 1 (test.jpg) from bob" @@ -9202,7 +9229,7 @@ testChannels1RelayDeliver ps = alice <## "group ID: 1" alice <## "subscribers: 4" -- subscriber refreshes count via short link - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice cath ##> "/_get group link data #1" cath <## "group ID: 1" cath <## "subscribers: 4" @@ -9424,20 +9451,26 @@ memberJoinChannelIncognito gName relays owners shortLink fullLink member = do -- | Assert that sender's member_relations_vector has 'MRIntroduced' at -- the recipient's index, looked up by display name on the same DB. memberIntroducedTo :: HasCallStack => TestCC -> T.Text -> T.Text -> IO () -memberIntroducedTo cc senderName recipientName = do - rows <- withCCTransaction cc $ \db -> - DB.query - db - [sql| - SELECT s.member_relations_vector, r.index_in_group - FROM group_members s, group_members r - WHERE s.local_display_name = ? AND r.local_display_name = ? - |] - (senderName, recipientName) :: - IO [(Maybe ByteString, Int64)] - case rows of - [(mv, idx)] -> getRelation idx (fromMaybe B.empty mv) `shouldBe` MRIntroduced - _ -> expectationFailure $ "memberIntroducedTo: expected exactly one row for " <> show (senderName, recipientName) <> ", got " <> show (length rows) +memberIntroducedTo cc senderName recipientName = go (50 :: Int) + where + go n = do + rows <- withCCTransaction cc $ \db -> + DB.query + db + [sql| + SELECT s.member_relations_vector, r.index_in_group + FROM group_members s, group_members r + WHERE s.local_display_name = ? AND r.local_display_name = ? + |] + (senderName, recipientName) :: + IO [(Maybe ByteString, Int64)] + case rows of + [(mv, idx)] + | relation == MRIntroduced || n == 0 -> relation `shouldBe` MRIntroduced + | otherwise -> threadDelay 100000 >> go (n - 1) + where + relation = getRelation idx (fromMaybe B.empty mv) + _ -> expectationFailure $ "memberIntroducedTo: expected exactly one row for " <> show (senderName, recipientName) <> ", got " <> show (length rows) testChannels1RelayDeliverLoop :: HasCallStack => Int -> TestParams -> IO () testChannels1RelayDeliverLoop deliveryBucketSize ps = @@ -9488,9 +9521,9 @@ testChannelsSenderDeduplicateOwn ps = do dan #> "#team 6" withTestChatCfgOpts ps cfg relayTestOpts "bob" $ \bob -> do - bob <## "subscribed 6 connections on server localhost" bob - <### [ WithTime "#team> 1", + <### [ "subscribed 6 connections on server localhost", + WithTime "#team> 1", WithTime "#team> 2", WithTime "#team> 3", WithTime "#team cath> 4", @@ -9923,6 +9956,7 @@ testChannelLinkAfterProfileUpdate ps = withNewTestChat ps "dan" danProfile $ \dan -> do (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob memberJoinChannel "team" [bob] [alice] shortLink fullLink cath + waitQueuedLinkUpdates alice -- owner updates channel profile alice ##> "/gp team my_team My team description" @@ -9957,6 +9991,7 @@ testChannelLinkAfterWelcomeUpdate ps = withNewTestChat ps "dan" danProfile $ \dan -> do (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob memberJoinChannel "team" [bob] [alice] shortLink fullLink cath + waitQueuedLinkUpdates alice -- owner updates channel welcome message alice ##> "/set welcome #team welcome to team" @@ -9995,6 +10030,7 @@ testChannelOwnerKeyAfterLinkUpdate ps = withNewTestChat ps "dan" danProfile $ \dan -> do (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob memberJoinChannel "team" [bob] [alice] shortLink fullLink cath + waitQueuedLinkUpdates alice threadDelay 100000 @@ -10201,10 +10237,31 @@ testChannelBlockMemberSigned ps = r2 `shouldEndWith` "(signed)" checkMemberRow :: HasCallStack => TestCC -> T.Text -> Maybe T.Text -> IO () -checkMemberRow cc name expectedRole = do - roles <- withCCTransaction cc $ \db -> - DB.query db "SELECT member_role FROM group_members WHERE local_display_name = ?" (Only name) :: IO [Only T.Text] - map (\(Only r) -> r) roles `shouldBe` maybeToList expectedRole +checkMemberRow cc name expectedRole = memberRoles cc name `shouldReturn` maybeToList expectedRole + +waitMemberRow :: HasCallStack => TestCC -> T.Text -> Maybe T.Text -> IO () +waitMemberRow cc name expectedRole = go (50 :: Int) + where + expected = maybeToList expectedRole + go n = do + roles <- memberRoles cc name + if roles == expected || n == 0 + then roles `shouldBe` expected + else threadDelay 100000 >> go (n - 1) + +memberRoles :: TestCC -> T.Text -> IO [T.Text] +memberRoles cc name = + map (\(Only r) -> r) <$> withCCTransaction cc (\db -> DB.query db "SELECT member_role FROM group_members WHERE local_display_name = ?" (Only name)) + +waitQueuedLinkUpdates :: HasCallStack => TestCC -> IO () +waitQueuedLinkUpdates cc = go (100 :: Int) + where + go n = do + [[queued]] <- withCCTransaction cc $ \db -> + DB.query_ db "SELECT COUNT(1) FROM commands WHERE command_function = 'set_short_link'" :: IO [[Int]] + if queued == 0 || n == 0 + then queued `shouldBe` 0 + else threadDelay 100000 >> go (n - 1) -- The wire member id for a named member (look it up on a client that knows the name, e.g. the owner), used to -- find a member by id on a subscriber that only knows it by member-id hash (e.g. after roster recovery). @@ -10285,7 +10342,7 @@ testChannelModeratorActionViaRoster ps = memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink frank -- the late joiner learns the roster from the served snapshot (verified below); under the -- no-broadcast model the apply finds no role change to surface, so no item here - threadDelay 1000000 -- the served roster arrives async + waitMemberRow frank "cath" (Just "moderator") checkMemberRole frank "cath" "moderator" where checkMemberRole :: HasCallStack => TestCC -> T.Text -> T.Text -> IO () @@ -10322,7 +10379,7 @@ testChannelSubscriberRosterCatchUp ps = -- the next privileged change (frank -> v2) reaches cath at a jumped version, triggering catch-up: -- cath requests the roster from the forwarding relay, which re-serves the current snapshot promoteChannelMember "team" alice bob frank [cath, dan, eve] - threadDelay 2000000 -- wait for the gap request + relay re-serve to recover dan + withCCTransaction cath (\db -> DB.query db "SELECT member_role, member_pub_key FROM group_members WHERE member_id = ?" (Only danId) :: IO [(T.Text, Maybe ByteString)]) `shouldEventuallyReturn` [("member", danKey)] -- cath recovered dan from the re-served roster: same member id, role, and owner-pinned key (recRole, recKey) <- getMemberRoleKey cath danId recRole `shouldBe` "member" @@ -10382,7 +10439,7 @@ testChannel2RelaysSubscriberRosterCatchUp ps = dan <### [EndsWith "from member to moderator (signed)"], frank <### [EndsWith "from member to moderator (signed)"] ] - threadDelay 2000000 -- wait for the gap request + relay re-serve to recover dan + withCCTransaction frank (\db -> DB.query db "SELECT member_role, member_pub_key FROM group_members WHERE member_id = ?" (Only danId) :: IO [(T.Text, Maybe ByteString)]) `shouldEventuallyReturn` [("member", danKey)] (recRole, recKey) <- getMemberRoleKey frank danId recRole `shouldBe` "member" recKey `shouldBe` danKey @@ -10447,8 +10504,7 @@ testChannelRoleTransitionsUpdateRoster ps = -- no separate role-change item under the no-broadcast model) threadDelay 100000 memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink dan - threadDelay 1000000 -- the served roster arrives async; wait before reading the applied state - checkMemberRow dan "cath" (Just "moderator") + waitMemberRow dan "cath" (Just "moderator") -- moderator -> admin: dan now knows cath, role event lands cleanly threadDelay 100000 alice ##> "/mr #team cath admin" @@ -10461,8 +10517,7 @@ testChannelRoleTransitionsUpdateRoster ps = -- eve joins; cached roster has cath as admin (learned from the served snapshot) threadDelay 100000 memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink eve - threadDelay 1000000 -- the served roster arrives async; wait before reading the applied state - checkMemberRow eve "cath" (Just "admin") + waitMemberRow eve "cath" (Just "admin") -- admin -> observer (crossing out of roster, since member is now in-roster): roster drops cath threadDelay 100000 alice ##> "/mr #team cath observer" @@ -10538,7 +10593,7 @@ testChannelRelayCannotForgePrivilegedMember ps = withNewTestChat ps "cath" cathProfile $ \cath -> do (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob memberJoinChannel "team" [bob] [alice] shortLink fullLink cath - threadDelay 1000000 + waitMemberRow cath "alice" (Just "owner") -- the forged attribution only resolves to a privileged author if the victim already holds the -- owner at GROwner (established via the group link on join) - this documents and guards that premise checkMemberRow cath "alice" (Just "owner") @@ -10613,7 +10668,7 @@ testChannelRemoveMemberSigned ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 4" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice cath ##> "/_get group link data #1" cath <## "group ID: 1" cath <## "subscribers: 4" @@ -10645,7 +10700,7 @@ testChannelRemoveMemberSigned ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 3" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice cath ##> "/_get group link data #1" cath <## "group ID: 1" cath <## "subscribers: 3" @@ -10674,7 +10729,7 @@ testChannelRemoveMemberSigned ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 2" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice cath ##> "/_get group link data #1" cath <## "group ID: 1" cath <## "subscribers: 2" @@ -10802,7 +10857,7 @@ testChannelSubscriberLeave ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 4" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice eve ##> "/_get group link data #1" eve <## "group ID: 1" eve <## "subscribers: 4" @@ -10826,7 +10881,7 @@ testChannelSubscriberLeave ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 3" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice eve ##> "/_get group link data #1" eve <## "group ID: 1" eve <## "subscribers: 3" @@ -10856,7 +10911,7 @@ testChannelSubscriberLeave ps = alice ##> "/_info #1" alice <## "group ID: 1" alice <## "subscribers: 2" - threadDelay 100000 -- wait for async short link data update + waitQueuedLinkUpdates alice eve ##> "/_get group link data #1" eve <## "group ID: 1" eve <## "subscribers: 2" @@ -10872,10 +10927,9 @@ testChannelSubscriberLeave ps = checkMemberStatus cath "dan" Nothing where checkMemberStatus :: HasCallStack => TestCC -> T.Text -> Maybe T.Text -> IO () - checkMemberStatus cc name expected = do - statuses <- withCCTransaction cc $ \db -> - DB.query db "SELECT member_status FROM group_members WHERE local_display_name = ?" (Only name) :: IO [Only T.Text] - map (\(Only s) -> s) statuses `shouldBe` maybeToList expected + checkMemberStatus cc name expected = + (map (\(Only s) -> s) <$> withCCTransaction cc (\db -> DB.query db "SELECT member_status FROM group_members WHERE local_display_name = ?" (Only name) :: IO [Only T.Text])) + `shouldEventuallyReturn` maybeToList expected testChannelRelayLeave :: HasCallStack => TestParams -> IO () testChannelRelayLeave ps = @@ -10941,7 +10995,7 @@ testChannelRelayLeave ps = (eve ("/_connect plan 1 " <> shortLink) frank <## "group link: channel has no active relays, please try to join later" where @@ -11265,8 +11319,7 @@ testChannelRosterMultipartReassembly ps = threadDelay 100000 memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink dan -- dan reassembles the multi-chunk roster from the served snapshot (arrives async) - threadDelay 1000000 - checkMemberRow dan "cath" (Just "moderator") + waitMemberRow dan "cath" (Just "moderator") where cfg = testCfg {fileChunkSize = 30} @@ -11295,7 +11348,7 @@ testChannelRosterDigestMismatchRejected ps = -- frank joins; bob re-serves the valid header with the corrupted blob, frank rejects it threadDelay 100000 memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink frank - threadDelay 1000000 + waitMemberRow frank "cath" (Just "observer") -- the rejected roster never elevates cath: the intro caps her to the channel default, so she -- stays observer (not moderator), and the version must not advance to the corrupted roster's version 1 checkMemberRow frank "cath" (Just "observer") @@ -11590,7 +11643,7 @@ testChannelRemoveLeftRelay ps = alice <## "#team: you removed cath from the group (signed)" -- dan syncs with link - should clean up cath's stale record - threadDelay 100000 + waitQueuedLinkUpdates alice dan ##> "/_get group link data #1" dan <## "group ID: 1" void $ getTermLine dan -- subscribers: N @@ -11690,7 +11743,7 @@ testRelayRejectAfterLeave ps = -- bob's transient row was created with relay_own_status='rejected'; -- after INFO arrives the cleanup arm deletes it. Original row 1 remains rejected. - threadDelay 1000000 + listRelayOwnStatuses bob `shouldEventuallyReturn` [(1, "rejected")] checkRelayGroupCount bob 1 finalStatuses <- listRelayOwnStatuses bob finalStatuses `shouldBe` [(1, "rejected")] @@ -11841,7 +11894,7 @@ testRelayRejectRaceConcurrentInvitations ps = alice <## "#team: group relays:" alice .<##. (" - relay id", ": invited") alice <## "#team: relay rejected, reason: RRRRejoinRejected" - threadDelay 1000000 + listRelayOwnStatuses bob `shouldEventuallyReturn` [(1, "rejected")] checkRelayGroupCount bob 1 -- subscriber doesn't receive between rejections (no active relay) @@ -11861,7 +11914,7 @@ testRelayRejectRaceConcurrentInvitations ps = alice #> "#team after second rejection" (cath withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> - withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do createChannel1Relay "team" alice bob cath dan eve -- the roster arrives as a file before this one; Postgres assigns it a new id and does not -- reuse it on delete (SQLite does), so the received message file is id 2 here, 1 on SQLite. @@ -12047,7 +12100,7 @@ testChannelMessageFile ps = ] where receiveFile cc name fileId src = do - let path = "./tests/tmp/test_" <> name <> ".jpg" + let path = tmpFile cc $ "test_" <> name <> ".jpg" cc ##> ("/fr " <> show fileId <> " " <> path) cc <### [ ConsoleString ("saving file " <> show fileId <> " from #team to " <> path), @@ -12062,7 +12115,7 @@ testChannelMessageFileCancel ps = withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> - withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do createChannel1Relay "team" alice bob cath dan eve #if defined(dbPostgres) let rcvFileId = 2 :: Int @@ -12242,7 +12295,7 @@ testChannelOwnerFileTransferAsMember ps = withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> - withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do createChannel1Relay "team" alice bob cath dan eve #if defined(dbPostgres) let rcvFileId = 2 :: Int @@ -12278,7 +12331,7 @@ testChannelOwnerFileTransferAsMember ps = ] where receiveFile cc name fileId src = do - let path = "./tests/tmp/test_" <> name <> ".jpg" + let path = tmpFile cc $ "test_" <> name <> ".jpg" cc ##> ("/fr " <> show fileId <> " " <> path) cc <### [ ConsoleString ("saving file " <> show fileId <> " from alice to " <> path), @@ -12293,7 +12346,7 @@ testGroupHistoryFileBadgeProof ps = do let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, fileSizeLimits = FileSizeLimits {noBadge = 100000, supporter = 300000, legend = 400000}} testChatCfg3 cfg aliceProfile bobProfile cathProfile (test sk) ps where - test sk alice bob cath = withXFTPServer $ do + test sk alice bob cath = withXFTPServer ps $ do createGroup2 "team" alice bob addTestBadge alice =<< issueTestBadge sk futureDate @@ -12322,14 +12375,14 @@ testGroupHistoryFileBadgeProof ps = do bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir ps) cath - <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from alice" ] cath <## "completed receiving file 1 (test.pdf) from alice" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test.pdf" + dest <- B.readFile (tmpFile ps "test.pdf") dest `shouldBe` src testGroupHistoryRcvFileBadgeProof :: HasCallStack => TestParams -> IO () @@ -12338,7 +12391,7 @@ testGroupHistoryRcvFileBadgeProof ps = do let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, fileSizeLimits = FileSizeLimits {noBadge = 100000, supporter = 300000, legend = 400000}} testChatCfg3 cfg aliceProfile bobProfile cathProfile (test sk) ps where - test sk alice bob cath = withXFTPServer $ do + test sk alice bob cath = withXFTPServer ps $ do createGroup2 "team" alice bob addTestBadge bob =<< issueTestBadge sk futureDate @@ -12346,11 +12399,11 @@ testGroupHistoryRcvFileBadgeProof ps = do bob <## "use /fc 1 to cancel sending" alice <# "#team bob> sends file test.pdf (266.0 KiB / 272376 bytes)" alice <## "use /fr 1 [/ | ] to receive it" - alice ##> "/fr 1 ./tests/tmp" + alice ##> ("/fr 1 " <> tmpDir ps) concurrentlyN_ [ bob <## "completed uploading file 1 (test.pdf) for #team", alice - <### [ "saving file 1 from bob to ./tests/tmp/test.pdf", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile ps "test.pdf", "started receiving file 1 (test.pdf) from bob" ] ] @@ -12375,14 +12428,14 @@ testGroupHistoryRcvFileBadgeProof ps = do bob <## "#team: new member cath is connected" ] - cath ##> "/fr 1 ./tests/tmp" + cath ##> ("/fr 1 " <> tmpDir ps) cath - <### [ "saving file 1 from bob to ./tests/tmp/test_1.pdf", + <### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile ps "test_1.pdf", "started receiving file 1 (test.pdf) from bob" ] cath <## "completed receiving file 1 (test.pdf) from bob" src <- B.readFile "./tests/fixtures/test.pdf" - dest <- B.readFile "./tests/tmp/test_1.pdf" + dest <- B.readFile (tmpFile ps "test_1.pdf") dest `shouldBe` src testChannelFileBadgeProof :: HasCallStack => TestParams -> IO () @@ -12393,7 +12446,7 @@ testChannelFileBadgeProof ps = do withNewTestChatCfgOpts ps cfg relayTestOpts "bob" bobProfile $ \bob -> withNewTestChatCfg ps cfg "cath" cathProfile $ \cath -> withNewTestChatCfg ps cfg "dan" danProfile $ \dan -> - withNewTestChatCfg ps cfg "eve" eveProfile $ \eve -> withXFTPServer $ do + withNewTestChatCfg ps cfg "eve" eveProfile $ \eve -> withXFTPServer ps $ do createChannel1Relay "team" alice bob cath dan eve addTestBadge alice =<< issueTestBadge sk futureDate #if defined(dbPostgres) @@ -12420,7 +12473,7 @@ testChannelFileBadgeProof ps = do ] src <- B.readFile "./tests/fixtures/test.jpg" - let path = "./tests/tmp/test_cath.jpg" + let path = tmpFile ps "test_cath.jpg" cath ##> ("/fr " <> show rcvFileId <> " " <> path) cath <### [ ConsoleString ("saving file " <> show rcvFileId <> " from alice to " <> path), @@ -12446,7 +12499,7 @@ testChannelFileBadgeProof ps = do eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" eve <## ("use /fr " <> show (rcvFileId + 1) <> " [/ | ] to receive it [>>]") ] - let path2 = "./tests/tmp/test_cath_2.jpg" + let path2 = tmpFile ps "test_cath_2.jpg" cath ##> ("/fr " <> show (rcvFileId + 1) <> " " <> path2) cath <### [ ConsoleString ("saving file " <> show (rcvFileId + 1) <> " from #team to " <> path2), @@ -12461,7 +12514,7 @@ testChannelOwnerFileCancelAsMember ps = withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> - withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do createChannel1Relay "team" alice bob cath dan eve #if defined(dbPostgres) let rcvFileId = 2 :: Int @@ -12805,8 +12858,9 @@ testChannelSignedFile ps = withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> withNewTestChat ps "dan" danProfile $ \dan -> - withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do - xftpCLI ["rand", "./tests/tmp/testfile", "1mb"] `shouldReturn` ["File created: ./tests/tmp/testfile"] + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do + let testfile = tmpFile ps "testfile" + xftpCLI ["rand", testfile, "1mb"] `shouldReturn` ["File created: " <> testfile] createChannel1Relay "team" alice bob cath dan eve promoteChannelMember "team" alice bob cath [dan, eve] -- roster serves arrive as files that Postgres deletes without reusing the id (SQLite reuses @@ -12836,9 +12890,9 @@ testChannelSignedFile ps = ] -- cath sends a signed file - cath ##> "/_send #1 sign=on json [{\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"signed file\",\"type\":\"file\"}}]" + cath ##> ("/_send #1 sign=on json [{\"filePath\": \"" <> testfile <> "\", \"msgContent\": {\"text\":\"signed file\",\"type\":\"file\"}}]") cath <# "#team signed file (signed)" - cath <# "/f #team ./tests/tmp/testfile" + cath <# ("/f #team " <> testfile) cath <## ("use /fc " <> show fileId <> " to cancel sending") cath <## ("completed uploading file " <> show fileId <> " (testfile) for #team") @@ -12859,14 +12913,14 @@ testChannelSignedFile ps = ] -- dan downloads: the signed digest is verified and the file completes - dan ##> ("/fr " <> show fileId <> " ./tests/tmp") + dan ##> ("/fr " <> show fileId <> " " <> tmpDir ps) dan - <### [ ConsoleString ("saving file " <> show fileId <> " from cath to ./tests/tmp/testfile_1"), + <### [ ConsoleString ("saving file " <> show fileId <> " from cath to " <> tmpFile ps "testfile_1"), ConsoleString ("started receiving file " <> show fileId <> " (testfile) from cath") ] dan <## ("completed receiving file " <> show fileId <> " (testfile) from cath") - src <- B.readFile "./tests/tmp/testfile" - destDan <- B.readFile "./tests/tmp/testfile_1" + src <- B.readFile testfile + destDan <- B.readFile (tmpFile ps "testfile_1") destDan `shouldBe` src -- the signed digest was carried to dan and stored, so verification ran (not skipped) and passed digestCount <- withCCTransaction dan $ \db -> @@ -12911,11 +12965,10 @@ testChannelMemberUpdateEnforcement ps = either (fail . show) (const $ pure ()) sent -- dan rejects the unsigned mutation of the held-signed item (RGEMsgBadSignature, stored not shown live), -- and the original signed content is not overwritten - threadDelay 2000000 + -- the rejection is recorded as a bad-signature item + (dan ##> "/_get chat #1 count=100 search=bad signature" >> chat <$> getTermLine dan) `shouldEventuallyReturn` [(0, "message rejected: bad signature")] -- (critical) the forged content did NOT overwrite the original signed item dan #$> ("/_get chat #1 count=100 search=secret", chat, [(0, "secret (signed)")]) - -- the rejection is recorded as a bad-signature item - dan #$> ("/_get chat #1 count=100 search=bad signature", chat, [(0, "message rejected: bad signature")]) -- a legitimate signed edit by cath is accepted cathMsgId <- lastItemId cath @@ -13292,9 +13345,8 @@ testChannelMemberDeleteEnforcement ps = sent <- runExceptT $ sendMessages bobAgent [(connId, PQEncOff, MsgFlags False, vrValue body)] either (fail . show) (const $ pure ()) sent -- dan rejects the unsigned delete of the held-signed item; item not deleted, rejection recorded - threadDelay 2000000 + (dan ##> "/_get chat #1 count=100 search=bad signature" >> chat <$> getTermLine dan) `shouldEventuallyReturn` [(0, "message rejected: bad signature")] dan #$> ("/_get chat #1 count=100 search=secret", chat, [(0, "secret (signed)")]) - dan #$> ("/_get chat #1 count=100 search=bad signature", chat, [(0, "message rejected: bad signature")]) -- a legitimate signed self-delete by cath is accepted cathMsgId <- lastItemId cath diff --git a/tests/ChatTests/Local.hs b/tests/ChatTests/Local.hs index 6760901c1d..ca1ccfd50d 100644 --- a/tests/ChatTests/Local.hs +++ b/tests/ChatTests/Local.hs @@ -121,7 +121,7 @@ testFiles :: TestParams -> IO () testFiles ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do -- setup createCCNoteFolder alice - let files = "./tests/tmp/app_files" + let files = tmpFile ps "app_files" alice ##> ("/_files_folder " <> files) alice <## "ok" @@ -170,10 +170,10 @@ testFiles ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do testOtherFiles :: TestParams -> IO () testOtherFiles = - testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do + testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> withXFTPServer alice $ do connectUsers alice bob createCCNoteFolder bob - bob ##> "/_files_folder ./tests/tmp/" + bob ##> ("/_files_folder " <> tmpDir bob) bob <## "ok" alice #> "/f @bob ./tests/fixtures/test.jpg" @@ -197,7 +197,7 @@ testOtherFiles = bob ##> "/tail *" bob ##> "/fs 1" bob <## "receiving file 1 (test.jpg) complete, path: test.jpg" - doesFileExist "./tests/tmp/test.jpg" `shouldReturn` True + doesFileExist (tmpFile bob "test.jpg") `shouldReturn` True where cfg = testCfg {inlineFiles = defaultInlineFilesConfig {offerChunks = 100, sendChunks = 100, receiveChunks = 100}} @@ -212,9 +212,10 @@ testCreateMulti ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do testCreateMultiFiles :: TestParams -> IO () testCreateMultiFiles ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do createCCNoteFolder alice - alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") - copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" - copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf" + let files = tmpFile ps "alice_app_files" + alice #$> ("/_files_folder " <> files, id, "ok") + copyFile "./tests/fixtures/test.jpg" (files "test.jpg") + copyFile "./tests/fixtures/test.pdf" (files "test.pdf") let cm1 = "{\"msgContent\": {\"type\": \"text\", \"text\": \"message without file\"}}" cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 1\"}}" @@ -227,8 +228,8 @@ testCreateMultiFiles ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do alice <# "* sending file 2" alice <# "* file 2 (test.pdf)" - doesFileExist "./tests/tmp/alice_app_files/test.jpg" `shouldReturn` True - doesFileExist "./tests/tmp/alice_app_files/test.pdf" `shouldReturn` True + doesFileExist (files "test.jpg") `shouldReturn` True + doesFileExist (files "test.pdf") `shouldReturn` True alice ##> "/_get chat *1 count=3" r <- chatF <$> getTermLine alice diff --git a/tests/ChatTests/Names.hs b/tests/ChatTests/Names.hs index 8e37c5e2d2..6421459124 100644 --- a/tests/ChatTests/Names.hs +++ b/tests/ChatTests/Names.hs @@ -28,7 +28,7 @@ chatNamesTests = do it "connect by name resolving to business (primary) and channel" testConnectByNameBusinessAndChannel testConnectByName :: HasCallStack => TestParams -> IO () -testConnectByName ps = withSmpServerAndNames $ \reg -> +testConnectByName ps = withSmpServerAndNames ps $ \reg -> testChat2 aliceProfile bobProfile (test reg) ps where aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" []) @@ -63,7 +63,7 @@ testConnectByName ps = withSmpServerAndNames $ \reg -> pure () testConnectByNameNotClaimed :: HasCallStack => TestParams -> IO () -testConnectByNameNotClaimed ps = withSmpServerAndNames $ \reg -> +testConnectByNameNotClaimed ps = withSmpServerAndNames ps $ \reg -> testChat2 aliceProfile bobProfile (test reg) ps where aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" []) @@ -76,7 +76,7 @@ testConnectByNameNotClaimed ps = withSmpServerAndNames $ \reg -> bob <## "SimpleX name alice.simplex is not included in the connection link's profile" testConnectByNameKnownContactNotClaimed :: HasCallStack => TestParams -> IO () -testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames $ \reg -> +testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames ps $ \reg -> testChat2 aliceProfile bobProfile (test reg) ps where aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" []) @@ -99,7 +99,7 @@ testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames $ \reg -> bob <## "SimpleX name alice.simplex is not included in the connection link's profile" testConnectByNameNotFound :: HasCallStack => TestParams -> IO () -testConnectByNameNotFound ps = withSmpServerAndNames $ \_reg -> +testConnectByNameNotFound ps = withSmpServerAndNames ps $ \_reg -> testChat2 aliceProfile bobProfile test ps where test _alice bob = do @@ -108,7 +108,7 @@ testConnectByNameNotFound ps = withSmpServerAndNames $ \_reg -> bob .<## "smpErr = NAME {nameErr = NOT_FOUND}}" testSetNameNotOwnAddress :: HasCallStack => TestParams -> IO () -testSetNameNotOwnAddress ps = withSmpServerAndNames $ \reg -> +testSetNameNotOwnAddress ps = withSmpServerAndNames ps $ \reg -> testChat2 aliceProfile bobProfile (test reg) ps where aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" []) @@ -124,7 +124,7 @@ testSetNameNotOwnAddress ps = withSmpServerAndNames $ \reg -> -- a self-claimed name is never auto-verified from link data: the claim is not proof of ownership testChannelDomainLinkJoinUnverified :: HasCallStack => TestParams -> IO () -testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames $ \reg -> +testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do @@ -144,7 +144,7 @@ testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames $ \reg -> teamName = SimplexNameInfo NTPublicGroup (SimplexDomain TLDSimplex "team" []) testChannelDomainVerify :: HasCallStack => TestParams -> IO () -testChannelDomainVerify ps = withSmpServerAndNames $ \reg -> +testChannelDomainVerify ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do @@ -174,7 +174,7 @@ testChannelDomainVerify ps = withSmpServerAndNames $ \reg -> teamName = SimplexNameInfo NTPublicGroup (SimplexDomain TLDSimplex "team" []) testConnectByChannelName :: HasCallStack => TestParams -> IO () -testConnectByChannelName ps = withSmpServerAndNames $ \reg -> +testConnectByChannelName ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do @@ -208,7 +208,7 @@ testConnectByChannelName ps = withSmpServerAndNames $ \reg -> -- first and succeeds (bob has joined #team), so it is the primary (planSimplexName); otherSimplexName -- is the direct contact @team.simplex, shown as "You can also connect to @team.simplex in direct chat". testConnectByNameChannelAndContact :: HasCallStack => TestParams -> IO () -testConnectByNameChannelAndContact ps = withSmpServerAndNames $ \reg -> +testConnectByNameChannelAndContact ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do @@ -247,7 +247,7 @@ testConnectByNameChannelAndContact ps = withSmpServerAndNames $ \reg -> -- channel #acme, shown as "You can also join channel #acme". The channel link is a real, fetchable -- #acme channel, so the failure is the faithful "channel does not claim this domain" case, not a broken link. testConnectByNameContactAndChannel :: HasCallStack => TestParams -> IO () -testConnectByNameContactAndChannel ps = withSmpServerAndNames $ \reg -> +testConnectByNameContactAndChannel ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do @@ -266,7 +266,7 @@ testConnectByNameContactAndChannel ps = withSmpServerAndNames $ \reg -> acmeName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "acme" []) testConnectByNameBusinessAndChannel :: HasCallStack => TestParams -> IO () -testConnectByNameBusinessAndChannel ps = withSmpServerAndNames $ \reg -> +testConnectByNameBusinessAndChannel ps = withSmpServerAndNames ps $ \reg -> withNewTestChat ps "alice" aliceProfile $ \alice -> withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> withNewTestChat ps "bob" bobProfile $ \bob -> do diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index f96eac2870..31ca1bae73 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -740,26 +740,26 @@ testCreateAddressOnServer :: HasCallStack => TestParams -> IO () testCreateAddressOnServer ps = testChat aliceProfile test ps where tmp = tmpPath ps - -- second SMP server, distinct from alice's configured server (localhost:7001) - altServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003" + -- second SMP server, distinct from alice's configured server + altServer = smpServer2Str ps altServerCfg = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } test alice = do withSmpServer' altServerCfg $ do - -- without a server the address is created on the configured server (7001) + -- without a server the address is created on the configured server alice ##> "/_address 1" (_, defaultLink) <- getContactLinks alice True - defaultLink `shouldContain` "localhost%3A7001" -- server is URL-encoded in the link + defaultLink `shouldContain` ("localhost%3A" <> smpTestPort ps) -- server is URL-encoded in the link alice ##> "/_delete_address 1" alice <## "Your chat address is deleted - accepted contacts will remain connected." alice <## "To create a new chat address use /ad" - -- with a server the address is pinned to the requested server (7003) + -- with a server the address is pinned to the requested server alice ##> ("/_address 1 " <> altServer) (_, pinnedLink) <- getContactLinks alice True - pinnedLink `shouldContain` "localhost%3A7003" + pinnedLink `shouldContain` ("localhost%3A" <> smpTestPort2 ps) alice <## "disconnected 1 connections on server localhost" testRetryConnectingViaContactLink :: HasCallStack => TestParams -> IO () @@ -803,8 +803,8 @@ testRetryConnectingViaContactLink ps = testChatCfgOpts2 cfg' opts' aliceProfile alice <## "disconnected 2 connections on server localhost" bob <## "disconnected 1 connections on server localhost" serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], msgQueueQuota = 2, serverStoreCfg = persistentServerStoreCfg tmp } @@ -814,7 +814,8 @@ testRetryConnectingViaContactLink ps = testChatCfgOpts2 cfg' opts' aliceProfile { agentConfig = testAgentCfg { quotaExceededTimeout = 1, - messageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval} + messageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}, + persistErrorInterval = 0 } } opts' = @@ -859,7 +860,7 @@ testRetryConnectingContactViaAddress ps = alice ##> "/_rotate_address_keys 1" _ <- getContactLink_ alice False alice <## "auto_accept off" - serverCfg' = smpServerCfg {transports = [("7003", transport @TLS, False)]} + serverCfg' = (smpServerCfg ps) {transports = [(smpTestPort2 ps, transport @TLS, False)]} cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}} opts' = testOpts @@ -1262,9 +1263,10 @@ testAutoReplyMessage = testChat2 aliceProfile bobProfile $ alice <## "bob (Bob): you can send messages to contact" alice <# "@bob hello!" concurrentlyN_ - [ do - bob <# "alice> hello!" - bob <## "alice (Alice): contact is connected", + [ bob + <### [ WithTime "alice> hello!", + "alice (Alice): contact is connected" + ], alice <## "bob (Bob): contact is connected" ] @@ -1284,11 +1286,8 @@ testBusinessAddress = testChat3 businessProfile aliceProfile {fullName = "Alice bob <## "contact address: connecting, allowed to reconnect" biz <## "#bob (Bob): accepting business address request..." bob <## "#biz: joining the group..." - -- the next command can be prone to race conditions - bob ##> ("/_connect plan 1 " <> cLink) - bob <## "business address: connecting to business #biz" + checkBusinessPlanWhileJoining bob cLink biz <## "#bob: bob_1 joined the group" - bob <## "#biz: you joined the group" biz #> "#bob hi" bob <# "#biz biz_1> hi" bob #> "#biz hello" @@ -1322,6 +1321,19 @@ testBusinessAddress = testChat3 businessProfile aliceProfile {fullName = "Alice (alice <# "#bob bob_1> hey there") (biz <# "#bob bob_1> hey there") +checkBusinessPlanWhileJoining :: HasCallStack => TestCC -> String -> IO () +checkBusinessPlanWhileJoining cc link = do + let cmd = "/_connect plan 1 " <> link + joined = "#biz: you joined the group" + known = "business address: known business #biz" + cc `send` cmd + ls <- replicateM 3 $ getTermLine cc + if known `elem` ls + then do + l <- getTermLine cc + (l : ls) `shouldMatchList` [cmd, joined, known, "use #biz to send messages"] + else ls `shouldMatchList` [cmd, joined, "business address: connecting to business #biz"] + testBusinessUpdateProfiles :: HasCallStack => TestParams -> IO () testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile cathProfile $ \biz alice bob cath -> do @@ -1404,8 +1416,10 @@ testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile c WithTime "#alisa alisa_1> hello again [>>]", WithTime "#alisa robert> hi there [>>]" ] - cath <## "#alisa: member alisa_1 is connected" - cath <## "#alisa: member robert is connected", + cath + <### [ "#alisa: member alisa_1 is connected", + "#alisa: member robert is connected" + ], biz <## "#alisa: cath joined the group", do alice <## "#biz: biz_1 added cath (Catherine) to the group (connecting...)" @@ -1417,6 +1431,8 @@ testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile c -- both customers receive business profile change biz ##> "/p business" biz <## "user profile is changed to business (your 1 contacts are notified)" + cath <## "contact biz changed to business" + cath <## "use @business to send messages" biz #> "#alisa hey" concurrentlyN_ [ do @@ -1427,10 +1443,7 @@ testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile c bob <## "biz_1 updated group #biz: (signed)" bob <## "changed to #business" bob <# "#business business_1> hey", - do - cath <## "contact biz changed to business" - cath <## "use @business to send messages" - cath <# "#alisa business> hey" + cath <# "#alisa business> hey" ] biz ##> "/set delete #alisa on" biz <## "updated group preferences:" @@ -1502,10 +1515,12 @@ testPlanAddressOwn ps = alice <## "contact address: own address" alice ##> ("/c " <> cLink) - alice <## "connection request sent!" - alice <## "alice_1 (Alice) wants to connect to you!" - alice <## "to accept: /ac alice_1" - alice <## "to reject: /rc alice_1 (the sender will NOT be notified)" + alice + <### [ "connection request sent!", + "alice_1 (Alice) wants to connect to you!", + "to accept: /ac alice_1", + "to reject: /rc alice_1 (the sender will NOT be notified)" + ] alice @@@ [("@alice_1", "Audio/video calls: enabled"), (":2", "")] alice ##> "/ac alice_1" alice <## "alice_1 (Alice): accepting contact request, you can send messages to contact" @@ -1554,10 +1569,12 @@ testPlanAddressConnecting ps = do threadDelay 100000 withTestChat ps "alice" $ \alice -> do - alice <## "subscribed 1 connections on server localhost" - alice <## "bob (Bob) wants to connect to you!" - alice <## "to accept: /ac bob" - alice <## "to reject: /rc bob (the sender will NOT be notified)" + alice + <### [ "subscribed 1 connections on server localhost", + "bob (Bob) wants to connect to you!", + "to accept: /ac bob", + "to reject: /rc bob (the sender will NOT be notified)" + ] alice ##> "/ac bob" alice <## "bob (Bob): accepting contact request, you can send messages to contact" withTestChat ps "bob" $ \bob -> do @@ -1934,8 +1951,10 @@ testSetConnectionIncognitoProhibitedDuringNegotiation ps = do alice ##> "/_set incognito :1 on" alice <## "chat db error: SEPendingConnectionNotFound {connId = 1}" withTestChat ps "bob" $ \bob -> do - bob <## "subscribed 1 connections on server localhost" - bob <## "alice (Alice): contact is connected" + bob + <### [ "subscribed 1 connections on server localhost", + "alice (Alice): contact is connected" + ] alice <##> bob alice `hasContactProfiles` ["alice", "bob"] bob `hasContactProfiles` ["alice", "bob"] @@ -2514,12 +2533,12 @@ testChangePCCUserDiffSrv ps = do alice ##> "/smp" alice <## "Your servers" alice <## " SMP servers" - alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001" - alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok") + alice <## (" " <> smpServerStr ps) + alice #$> ("/smp " <> altServer, id, "ok") alice ##> "/smp" alice <## "Your servers" alice <## " SMP servers" - alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003" + alice <## (" " <> altServer) alice ##> "/user alice" showActiveUser alice "alice (Alice)" -- Change connection to newly created user and use the newly created connection @@ -2541,9 +2560,10 @@ testChangePCCUserDiffSrv ps = do (bob <## "alisa: contact is connected") alice <##> bob where + altServer = "smp://" <> testServerKeyHash <> ":server_password@127.0.0.1:" <> smpTestPort2 ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False), ("7002", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False), (xftpTestPort ps, transport @TLS, False)], msgQueueQuota = 2 } @@ -2581,13 +2601,13 @@ testSetGroupAlias = testChat2 aliceProfile bobProfile $ testSetContactPrefs :: HasCallStack => TestParams -> IO () testSetContactPrefs = testChat2 aliceProfile bobProfile $ - \alice bob -> withXFTPServer $ do - alice #$> ("/_files_folder ./tests/tmp/alice", id, "ok") - bob #$> ("/_files_folder ./tests/tmp/bob", id, "ok") - createDirectoryIfMissing True "./tests/tmp/alice" - createDirectoryIfMissing True "./tests/tmp/bob" - copyFile "./tests/fixtures/test.txt" "./tests/tmp/alice/test.txt" - copyFile "./tests/fixtures/test.txt" "./tests/tmp/bob/test.txt" + \alice bob -> withXFTPServer alice $ do + alice #$> ("/_files_folder " <> tmpFile alice "alice", id, "ok") + bob #$> ("/_files_folder " <> tmpFile bob "bob", id, "ok") + createDirectoryIfMissing True $ tmpFile alice "alice" + createDirectoryIfMissing True $ tmpFile bob "bob" + copyFile "./tests/fixtures/test.txt" $ tmpFile alice "alice/test.txt" + copyFile "./tests/fixtures/test.txt" $ tmpFile bob "bob/test.txt" bob ##> "/_profile 1 {\"displayName\": \"bob\", \"fullName\": \"\", \"shortDescr\": \"Bob\", \"preferences\": {\"voice\": {\"allow\": \"no\"}, \"receipts\": {\"allow\": \"yes\", \"activated\": true}}}" bob <## "profile image removed" bob <## "updated preferences:" @@ -2706,8 +2726,7 @@ testUpdateGroupPrefs = bob <## "alice updated group #team: (signed)" bob <## "updated group preferences:" bob <## "Full deletion: on" - threadDelay 500000 - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "Full deletion: on")]) alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}" alice <## "updated group preferences:" alice <## "Full deletion: off" @@ -2717,8 +2736,7 @@ testUpdateGroupPrefs = bob <## "updated group preferences:" bob <## "Full deletion: off" bob <## "Voice messages: off" - threadDelay 500000 - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")]) alice ##> "/set voice #team on" alice <## "updated group preferences:" alice <## "Voice messages: on" @@ -2726,8 +2744,7 @@ testUpdateGroupPrefs = bob <## "alice updated group #team: (signed)" bob <## "updated group preferences:" bob <## "Voice messages: on" - threadDelay 500000 - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")]) threadDelay 500000 alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}" -- no update @@ -2780,7 +2797,7 @@ testAllowFullDeletionGroup = bob <## "updated group preferences:" bob <## "Full deletion: on" alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "hi"), (0, "hey"), (1, "Full deletion: on")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")]) + (bob ##> "/_get chat #1 count=100" >> chat <$> getTermLine bob) `shouldEventuallyReturn` (groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")]) bob #$> ("/_delete item #1 " <> msgItemId <> " broadcast", id, "message deleted") alice <# "#team bob> [deleted] hey" alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "hi"), (1, "Full deletion: on")]) @@ -2849,41 +2866,41 @@ testEnableTimedMessagesContact = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob - alice ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}" + alice ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 3}}" alice <## "you updated preferences for bob:" - alice <## "Disappearing messages: enabled (you allow: yes (1 sec), contact allows: yes)" + alice <## "Disappearing messages: enabled (you allow: yes (3 sec), contact allows: yes)" bob <## "alice updated preferences for you:" - bob <## "Disappearing messages: enabled (you allow: yes (1 sec), contact allows: yes (1 sec))" + bob <## "Disappearing messages: enabled (you allow: yes (3 sec), contact allows: yes (3 sec))" bob ##> "/set disappear @alice yes" bob <## "your preferences for alice did not change" alice <##> bob threadDelay 500000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)"), (1, "hi"), (0, "hey")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)"), (0, "hi"), (1, "hey")]) - threadDelay 1000000 + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (3 sec)"), (1, "hi"), (0, "hey")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (3 sec)"), (0, "hi"), (1, "hey")]) + threadDelay 3000000 alice <### ["timed message deleted: hi", "timed message deleted: hey"] bob <### ["timed message deleted: hi", "timed message deleted: hey"] - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)")]) + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (3 sec)")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (3 sec)")]) -- turn off, messages are not disappearing bob ##> "/set disappear @alice no" bob <## "you updated preferences for alice:" - bob <## "Disappearing messages: off (you allow: no, contact allows: yes (1 sec))" + bob <## "Disappearing messages: off (you allow: no, contact allows: yes (3 sec))" alice <## "bob updated preferences for you:" - alice <## "Disappearing messages: off (you allow: yes (1 sec), contact allows: no)" + alice <## "Disappearing messages: off (you allow: yes (3 sec), contact allows: no)" alice <##> bob threadDelay 1500000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)"), (0, "Disappearing messages: off"), (1, "hi"), (0, "hey")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)"), (1, "Disappearing messages: off"), (0, "hi"), (1, "hey")]) + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (3 sec)"), (0, "Disappearing messages: off"), (1, "hi"), (0, "hey")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (3 sec)"), (1, "Disappearing messages: off"), (0, "hi"), (1, "hey")]) -- test api bob ##> "/set disappear @alice yes 30s" bob <## "you updated preferences for alice:" - bob <## "Disappearing messages: enabled (you allow: yes (30 sec), contact allows: yes (1 sec))" + bob <## "Disappearing messages: enabled (you allow: yes (30 sec), contact allows: yes (3 sec))" alice <## "bob updated preferences for you:" alice <## "Disappearing messages: enabled (you allow: yes (30 sec), contact allows: yes (30 sec))" bob ##> "/set disappear @alice week" -- "yes" is optional bob <## "you updated preferences for alice:" - bob <## "Disappearing messages: enabled (you allow: yes (1 week), contact allows: yes (1 sec))" + bob <## "Disappearing messages: enabled (you allow: yes (1 week), contact allows: yes (3 sec))" alice <## "bob updated preferences for you:" alice <## "Disappearing messages: enabled (you allow: yes (1 week), contact allows: yes (1 week))" @@ -2893,23 +2910,23 @@ testEnableTimedMessagesGroup = \alice bob -> do createGroup2 "team" alice bob threadDelay 1000000 - alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"timedMessages\": {\"enable\": \"on\", \"ttl\": 1}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}" + alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"\", \"groupPreferences\": {\"timedMessages\": {\"enable\": \"on\", \"ttl\": 3}, \"directMessages\": {\"enable\": \"on\"}, \"history\": {\"enable\": \"on\"}}}" alice <## "updated group preferences:" - alice <## "Disappearing messages: on (1 sec)" + alice <## "Disappearing messages: on (3 sec)" bob <## "alice updated group #team: (signed)" bob <## "updated group preferences:" - bob <## "Disappearing messages: on (1 sec)" + bob <## "Disappearing messages: on (3 sec)" threadDelay 1000000 alice #> "#team hi" bob <# "#team alice> hi" threadDelay 500000 - alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (1 sec)"), (1, "hi")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)"), (0, "hi")]) - threadDelay 1000000 + alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (3 sec)"), (1, "hi")]) + bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (3 sec)"), (0, "hi")]) + threadDelay 3000000 alice <## "timed message deleted: hi" bob <## "timed message deleted: hi" - alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (1 sec)")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)")]) + alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (3 sec)")]) + bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (3 sec)")]) -- turn off, messages are not disappearing alice ##> "/set disappear #team off" alice <## "updated group preferences:" @@ -2921,8 +2938,8 @@ testEnableTimedMessagesGroup = alice #> "#team hey" bob <# "#team alice> hey" threadDelay 1500000 - alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (1 sec)"), (1, "Disappearing messages: off"), (1, "hey")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)"), (0, "Disappearing messages: off"), (0, "hey")]) + alice #$> ("/_get chat #1 count=100", chat, sndGroupFeatures <> [(0, "connected"), (1, "Disappearing messages: on (3 sec)"), (1, "Disappearing messages: off"), (1, "hey")]) + bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (3 sec)"), (0, "Disappearing messages: off"), (0, "hey")]) -- test api alice ##> "/set disappear #team on 30s" alice <## "updated group preferences:" @@ -2944,20 +2961,20 @@ testTimedMessagesEnabledGlobally = alice ##> "/set disappear yes" alice <## "user profile did not change" connectUsers alice bob - bob ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}" + bob ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 3}}" bob <## "you updated preferences for alice:" - bob <## "Disappearing messages: enabled (you allow: yes (1 sec), contact allows: yes)" + bob <## "Disappearing messages: enabled (you allow: yes (3 sec), contact allows: yes)" alice <## "bob updated preferences for you:" - alice <## "Disappearing messages: enabled (you allow: yes (1 sec), contact allows: yes (1 sec))" + alice <## "Disappearing messages: enabled (you allow: yes (3 sec), contact allows: yes (3 sec))" alice <##> bob threadDelay 500000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)"), (1, "hi"), (0, "hey")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)"), (0, "hi"), (1, "hey")]) - threadDelay 1000000 + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (3 sec)"), (1, "hi"), (0, "hey")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (3 sec)"), (0, "hi"), (1, "hey")]) + threadDelay 3000000 alice <### ["timed message deleted: hi", "timed message deleted: hey"] bob <### ["timed message deleted: hi", "timed message deleted: hey"] - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")]) + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (3 sec)")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (3 sec)")]) testUpdateMultipleUserPrefs :: HasCallStack => TestParams -> IO () testUpdateMultipleUserPrefs = testChat3 aliceProfile bobProfile cathProfile $ @@ -3057,13 +3074,13 @@ testGroupPrefsDirectForRole = testChat4 aliceProfile bobProfile cathProfile danP testGroupPrefsFilesForRole :: HasCallStack => TestParams -> IO () testGroupPrefsFilesForRole = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do - alice #$> ("/_files_folder ./tests/tmp/alice", id, "ok") - bob #$> ("/_files_folder ./tests/tmp/bob", id, "ok") - createDirectoryIfMissing True "./tests/tmp/alice" - createDirectoryIfMissing True "./tests/tmp/bob" - copyFile "./tests/fixtures/test.txt" "./tests/tmp/alice/test1.txt" - copyFile "./tests/fixtures/test.txt" "./tests/tmp/bob/test2.txt" + \alice bob cath -> withXFTPServer alice $ do + alice #$> ("/_files_folder " <> tmpFile alice "alice", id, "ok") + bob #$> ("/_files_folder " <> tmpFile bob "bob", id, "ok") + createDirectoryIfMissing True $ tmpFile alice "alice" + createDirectoryIfMissing True $ tmpFile bob "bob" + copyFile "./tests/fixtures/test.txt" $ tmpFile alice "alice/test1.txt" + copyFile "./tests/fixtures/test.txt" $ tmpFile bob "bob/test2.txt" createGroup3 "team" alice bob cath threadDelay 1000000 alice ##> "/set files #team on owner" @@ -3092,7 +3109,7 @@ testGroupPrefsFilesForRole = testChat3 aliceProfile bobProfile cathProfile $ testGroupPrefsSimplexLinksForRole :: HasCallStack => TestParams -> IO () testGroupPrefsSimplexLinksForRole = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> withXFTPServer $ do + \alice bob cath -> withXFTPServer alice $ do createGroup3 "team" alice bob cath threadDelay 1000000 alice ##> "/set links #team on owner" @@ -3355,9 +3372,10 @@ testShortLinkJoinGroup = do cath <## "#team: alice added dan (Daniel) to the group (connecting...)" cath <## "#team: new member dan is connected", - do - dan <## "#team: member bob (Bob) is connected" - dan <## "#team: member cath (Catherine) is connected" + dan + <### [ "#team: member bob (Bob) is connected", + "#team: member cath (Catherine) is connected" + ] ] dan ##> ("/_connect plan 1 " <> fullLink) dan <## "group link: known group #team" @@ -3397,10 +3415,13 @@ testShortLinkInvitationPrepareContact = testChat2 aliceProfile bobProfile test <### [ "alice: connection started", WithTime "@alice hello" ] - alice <# "bob> hello" concurrently_ (bob <## "alice (Alice): contact is connected") - (alice <## "bob (Bob): contact is connected") + ( alice + <### [ WithTime "bob> hello", + "bob (Bob): contact is connected" + ] + ) alice <##> bob bob ##> ("/_connect plan 1 " <> shortLink) bob <## "invitation link: known contact alice" @@ -3427,15 +3448,19 @@ testShortLinkInvitationImage = testChat2 aliceProfile bobProfile test <### [ "bob: connection started", WithTime "@bob hello" ] - bob <# "alice> hello" concurrently_ (alice <## "bob (Bob): contact is connected") - (bob <## "alice (Alice): contact is connected") + ( bob + <### [ WithTime "alice> hello", + "alice (Alice): contact is connected" + ] + ) bob <##> alice testShortLinkInvitationConnectRetry :: HasCallStack => TestParams -> IO () -testShortLinkInvitationConnectRetry ps = testChatOpts2 opts' aliceProfile bobProfile test ps +testShortLinkInvitationConnectRetry ps = testChatCfgOpts2 cfg' opts' aliceProfile bobProfile test ps where + cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}} test alice bob = do shortLink <- withSmpServer' serverCfg' $ do alice ##> "/_connect 1" @@ -3459,17 +3484,20 @@ testShortLinkInvitationConnectRetry ps = testChatOpts2 opts' aliceProfile bobPro <### [ "alice: connection started", WithTime "@alice hello" ] - alice <# "bob> hello" concurrently_ (bob <## "alice (Alice): contact is connected") - (alice <## "bob (Bob): contact is connected") + ( alice + <### [ WithTime "bob> hello", + "bob (Bob): contact is connected" + ] + ) alice <##> bob alice <## "disconnected 1 connections on server localhost" bob <## "disconnected 1 connections on server localhost" tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -3641,8 +3669,8 @@ testShortLinkAddressConnectRetry ps = where tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -3675,11 +3703,11 @@ testShortLinkAddressConnectRetryIncognito ps = bob ##> ("/_connect plan 1 " <> shortLink) bob <## "contact address: known prepared contact alice" bob ##> "/_connect contact @2 incognito=on text hello" - bobIncognito <- getTermLine bob - bob - <### [ "alice: connection started incognito", - WithTime "i @alice hello" - ] + line <- getTermLine bob + let helloFirst = dropTime_ line == Just "i @alice hello" + bobIncognito <- if helloFirst then getTermLine bob else pure line + bob <## "alice: connection started incognito" + unless helloFirst $ bob <# "i @alice hello" alice <### [ ConsoleString (bobIncognito <> " wants to connect to you!"), WithTime (bobIncognito <> "> hello") @@ -3704,8 +3732,8 @@ testShortLinkAddressConnectRetryIncognito ps = where tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -3735,11 +3763,8 @@ testShortLinkAddressPrepareBusiness = testChat3 businessProfile aliceProfile {fu bob <## "#biz: connection started" biz <## "#bob (Bob): accepting business address request..." bob <## "#biz: joining the group..." - -- the next command can be prone to race conditions - bob ##> ("/_connect plan 1 " <> shortLink) - bob <## "business address: connecting to business #biz" + checkBusinessPlanWhileJoining bob shortLink biz <## "#bob: bob_1 joined the group" - bob <## "#biz: you joined the group" biz #> "#bob hi" bob <# "#biz biz_1> hi" bob #> "#biz hello" @@ -3960,10 +3985,10 @@ testShortLinkGroupRetry ps = testChatOpts2 opts' aliceProfile bobProfile test ps bob ##> "/_connect group #1" bob <##. "smp agent error: BROKER" withSmpServer' serverCfg' $ do - bob ##> ("/_connect plan 1 " <> shortLink) - bob <## "group link: known prepared group #team" alice <## "subscribed 2 connections on server localhost" bob <## "subscribed 1 connections on server localhost" + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "group link: known prepared group #team" threadDelay 250000 bob ##> "/_connect group #1" bob <## "#team: connection started" @@ -3986,8 +4011,8 @@ testShortLinkGroupRetry ps = testChatOpts2 opts' aliceProfile bobProfile test ps bob <## "disconnected 2 connections on server localhost" tmp = tmpPath ps serverCfg' = - smpServerCfg - { transports = [("7003", transport @TLS, False)], + (smpServerCfg ps) + { transports = [(smpTestPort2 ps, transport @TLS, False)], serverStoreCfg = persistentServerStoreCfg tmp } opts' = @@ -4084,10 +4109,13 @@ testShortLinkChangePreparedContactUser = testChat2 aliceProfile bobProfile test <### [ "alice: connection started", WithTime "@alice hello" ] - alice <# "robert> hello" concurrently_ (bob <## "alice (Alice): contact is connected") - (alice <## "robert: contact is connected") + ( alice + <### [ WithTime "robert> hello", + "robert: contact is connected" + ] + ) alice <##> bob @@ -4136,10 +4164,13 @@ testShortLinkChangePreparedContactUserDuplicate = testChat2 aliceProfile bobProf <### [ "alice_1: connection started", WithTime "@alice_1 hello" ] - alice <# "robert_1> hello" concurrently_ (bob <## "alice_1 (Alice): contact is connected") - (alice <## "robert_1: contact is connected") + ( alice + <### [ WithTime "robert_1> hello", + "robert_1: contact is connected" + ] + ) alice #> "@robert_1 hi" bob <# "alice_1> hi" @@ -4340,13 +4371,13 @@ testShortLinkChangePreparedGroupUserDuplicate = testChat3 aliceProfile bobProfil ] cath <# "#team alice> 4" - bob #> "#team_1 5" + bob `send` "#team_1 5" + bob <### [WithTime "#team_1 5", WithTime "#team robert_2> 5"] [alice, cath] *<# "#team robert> 5" - bob <# "#team robert_2> 5" - bob #> "#team 6" + bob `send` "#team 6" + bob <### [WithTime "#team 6", WithTime "#team_1 robert_1> 6"] [alice, cath] *<# "#team robert_1> 6" - bob <# "#team_1 robert_1> 6" threadDelay 1000000 cath #> "#team 7" @@ -4387,13 +4418,14 @@ testShortLinkInvitationSetIncognito = testChat2 aliceProfile bobProfile test <### [ ConsoleString (aliceIncognito <> ": connection started"), WithTime ("@" <> aliceIncognito <> " hello") ] - alice ?<# "bob> hello" - _ <- getTermLine alice concurrentlyN_ [ bob <## (aliceIncognito <> ": contact is connected"), - do - alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito) - alice <## "use /i bob to print out this incognito profile again" + alice + <### [ WithTime "i bob> hello", + ConsoleString aliceIncognito, + ConsoleString ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito), + "use /i bob to print out this incognito profile again" + ] ] alice ?#> ("@bob hi") bob <# (aliceIncognito <> "> hi") @@ -4432,10 +4464,13 @@ testShortLinkInvitationChangeUser = testChat2 aliceProfile bobProfile test <### [ "alisa: connection started", WithTime "@alisa hello" ] - alice <# "bob> hello" concurrently_ (bob <## "alisa: contact is connected") - (alice <## "bob (Bob): contact is connected") + ( alice + <### [ WithTime "bob> hello", + "bob (Bob): contact is connected" + ] + ) alice <##> bob testShortLinkAddressChangeProfile :: HasCallStack => TestParams -> IO () @@ -4573,11 +4608,13 @@ testShortLinkGroupChangeProfileReceived = testChat3 aliceProfile bobProfile cath cath <## "changed to #club" alice <## "cath updated group #team: (signed)" alice <## "changed to #club" - threadDelay 250000 - bob ##> ("/_connect plan 1 " <> shortLink) - bob <## "group link: ok to connect directly" - groupSLinkData <- getTermLine bob + let planGroupLinkData = do + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "group link: ok to connect directly" + getTermLine bob + (T.isInfixOf "\"displayName\":\"club\"" . T.pack <$> planGroupLinkData) `shouldEventuallyReturn` True + groupSLinkData <- planGroupLinkData bob ##> ("/_prepare group 1 " <> fullLink <> " " <> shortLink <> " " <> groupSLinkData) bob <## "#club: group is prepared" bob ##> "/_connect group #1" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 9586957281..cd975a32c3 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -13,7 +13,7 @@ import ChatTests.DBUtils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_, mapConcurrently_) import Control.Concurrent.STM -import Control.Monad (unless, when) +import Control.Monad (join, unless, when) import Control.Monad.Except (runExceptT) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 @@ -34,7 +34,7 @@ import Simplex.Chat.Store.Profiles (getUserContactProfiles) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared -import Simplex.FileTransfer.Client.Main (xftpClientCLI) +import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -43,8 +43,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern P import Simplex.Messaging.Encoding.String import Simplex.Messaging.Version import System.Directory (doesFileExist) -import System.Environment (lookupEnv, withArgs) -import System.IO.Silently (capture_) +import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec hiding (it) import qualified Test.Hspec as Hspec @@ -95,7 +94,7 @@ it :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expe it name test = Hspec.it name $ \tmp -> timeout t (test tmp) >>= maybe (error "test timed out") pure where - t = 90 * 1000000 + t = 180 * 1000000 xit' :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation)) xit' = if os == "linux" then xit else it @@ -127,9 +126,9 @@ versionTestMatrix2 runTest = do it "prev" $ runTestCfg2 testCfgVPrev testCfgVPrev (runTest True True) it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev (runTest True True) it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg (runTest True True) - it "old (1st supported)" $ testChatCfg2 testCfgV1 aliceProfile bobProfile (runTest True False) + it "old (1st supported)" $ testChatCfg2 testCfgV1 aliceProfile bobProfile (runTest True True) it "old to curr" $ runTestCfg2 testCfg testCfgV1 (runTest True True) - it "curr to old" $ runTestCfg2 testCfgV1 testCfg (runTest True False) + it "curr to old" $ runTestCfg2 testCfgV1 testCfg (runTest True True) versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith TestParams versionTestMatrix3 runTest = do @@ -680,11 +679,24 @@ createCCNoteFolder cc = withCCUser cc $ \user -> runExceptT (createNoteFolder db user) >>= either (fail . show) pure +shouldEventuallyReturn :: (HasCallStack, Eq a, Show a) => IO a -> a -> Expectation +shouldEventuallyReturn action expected = go (200 :: Int) + where + go n = do + r <- action + if r == expected || n == 0 + then r `shouldBe` expected + else threadDelay 100000 >> go (n - 1) + getProfilePictureByName :: TestCC -> String -> IO (Maybe String) getProfilePictureByName cc displayName = withTransaction (chatStore $ chatController cc) $ \db -> - maybeFirstRow fromOnly $ - DB.query db "SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1" (Only displayName) + join <$> maybeFirstRow fromOnly (DB.query db "SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1" (Only displayName)) + +getProfileShortDescrByName :: TestCC -> String -> IO (Maybe String) +getProfileShortDescrByName cc displayName = + withTransaction (chatStore $ chatController cc) $ \db -> + join <$> maybeFirstRow fromOnly (DB.query db "SELECT short_descr FROM contact_profiles WHERE display_name = ? LIMIT 1" (Only displayName)) pqSndForContact :: TestCC -> ContactId -> IO PQEncryption pqSndForContact = pqForContact_ pqSndEnabled PQEncOff @@ -814,8 +826,10 @@ createGroup4 gName cc1 (cc2, role2) (cc3, role3) (cc4, role4) = do [ cc1 <## "#team: dan joined the group", do cc4 <## ("#" <> gName <> ": you joined the group") - cc4 <## ("#" <> gName <> ": member " <> sName2 <> " is connected") - cc4 <## ("#" <> gName <> ": member " <> sName3 <> " is connected"), + cc4 + <### [ ConsoleString ("#" <> gName <> ": member " <> sName2 <> " is connected"), + ConsoleString ("#" <> gName <> ": member " <> sName3 <> " is connected") + ], do cc2 <## ("#" <> gName <> ": " <> name1 <> " added " <> sName4 <> " to the group (connecting...)") cc2 <## ("#" <> gName <> ": new member " <> name4 <> " is connected"), @@ -890,7 +904,12 @@ linkAnotherSchema link | otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/" xftpCLI :: [String] -> IO [String] -xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI) +xftpCLI = \case + ["rand", path, size] -> do + let FileSize n = fromString size :: FileSize Int + B.writeFile path =<< atomically . C.randomBytes n =<< C.newRandom + pure ["File created: " <> path] + params -> error $ "unsupported xftp CLI command: " <> unwords params setRelativePaths :: HasCallStack => TestCC -> String -> String -> IO () setRelativePaths cc filesFolder tempFolder = do diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 2ab4cae0d6..c191402e9f 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -232,8 +232,8 @@ storedBindingsTest = testRemote $ \compress mobile desktop -> do desktop ##> "/stop remote host new" desktop <## "ok" - desktop ##> ("/start remote host new addr=" <> localAddress <> " iface=\"lo\" port=52230") - desktop <## ("new remote host started on " <> localAddress <> ":52230") + desktop ##> ("/start remote host new addr=" <> localAddress <> " iface=\"lo\" port=" <> remoteTestPort desktop) + desktop <## ("new remote host started on " <> localAddress <> ":" <> remoteTestPort desktop) desktop <##. "other addresses: " desktop <## "Remote session invitation:" inv <- getTermLine desktop @@ -286,17 +286,17 @@ remoteMessageTest = testRemote3 $ \compress mobile desktop bob -> do remoteStoreFileTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () remoteStoreFileTest = testRemote3 $ \compress mobile desktop bob -> - withXFTPServer $ do - let mobileFiles = "./tests/tmp/mobile_files" + withXFTPServer mobile $ do + let mobileFiles = tmpFile mobile "mobile_files" mobile ##> ("/_files_folder " <> mobileFiles) mobile <## "ok" - let desktopFiles = "./tests/tmp/desktop_files" + let desktopFiles = tmpFile desktop "desktop_files" desktop ##> ("/_files_folder " <> desktopFiles) desktop <## "ok" - let desktopHostFiles = "./tests/tmp/remote_hosts_data" + let desktopHostFiles = tmpFile desktop "remote_hosts_data" desktop ##> ("/remote_hosts_folder " <> desktopHostFiles) desktop <## "ok" - let bobFiles = "./tests/tmp/bob_files" + let bobFiles = tmpFile bob "bob_files" bob ##> ("/_files_folder " <> bobFiles) bob <## "ok" @@ -328,7 +328,7 @@ remoteStoreFileTest = runExceptT (remoteStoreFile rhClient "tests/fixtures/test.pdf" "../x") >>= \case Left (RPEInvalidBody _) -> pure () r -> fail $ "expected RPEInvalidBody, got " <> show r - doesFileExist "./tests/tmp/x" `shouldReturn` False + doesFileExist (tmpFile mobile "x") `shouldReturn` False -- the undrained attachment did not break the session desktop ##> "/store remote file 1 tests/fixtures/test.pdf" desktop <## "file test_3.pdf stored on remote host 1" @@ -353,8 +353,10 @@ remoteStoreFileTest = [ do desktop <## "completed uploading file 1 (test_1.pdf) for bob", do - bob <## "saving file 1 from alice to test_1.pdf" - bob <## "started receiving file 1 (test_1.pdf) from alice" + bob + <### [ "saving file 1 from alice to test_1.pdf", + "started receiving file 1 (test_1.pdf) from alice" + ] bob <## "completed receiving file 1 (test_1.pdf) from alice" ] B.readFile (bobFiles "test_1.pdf") `shouldReturn` src @@ -381,8 +383,10 @@ remoteStoreFileTest = [ do desktop <## "completed uploading file 2 (test_2.pdf) for bob", do - bob <## "saving file 2 from alice to test_2.pdf" - bob <## "started receiving file 2 (test_2.pdf) from alice" + bob + <### [ "saving file 2 from alice to test_2.pdf", + "started receiving file 2 (test_2.pdf) from alice" + ] bob <## "completed receiving file 2 (test_2.pdf) from alice" ] B.readFile (bobFiles "test_2.pdf") `shouldReturn` src @@ -398,8 +402,10 @@ remoteStoreFileTest = [ do bob <## "completed uploading file 3 (test.jpg) for alice", do - desktop <## "saving file 3 from bob to test.jpg" - desktop <## "started receiving file 3 (test.jpg) from bob" + desktop + <### [ "saving file 3 from bob to test.jpg", + "started receiving file 3 (test.jpg) from bob" + ] desktop <## "completed receiving file 3 (test.jpg) from bob" ] Just cfArgs'@(CFArgs key' nonce') <- J.decode . LB.pack <$> getTermLine desktop @@ -426,13 +432,13 @@ remoteStoreFileTest = r `shouldContain` err remoteCLIFileTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () -remoteCLIFileTest = testRemote3 $ \compress mobile desktop bob -> withXFTPServer $ do - let mobileFiles = "./tests/tmp/mobile_files" +remoteCLIFileTest = testRemote3 $ \compress mobile desktop bob -> withXFTPServer mobile $ do + let mobileFiles = tmpFile mobile "mobile_files" mobile ##> ("/_files_folder " <> mobileFiles) mobile <## "ok" - let bobFiles = "./tests/tmp/bob_files/" + let bobFiles = tmpFile bob "bob_files/" createDirectoryIfMissing True bobFiles - let desktopHostFiles = "./tests/tmp/remote_hosts_data" + let desktopHostFiles = tmpFile desktop "remote_hosts_data" desktop ##> ("/remote_hosts_folder " <> desktopHostFiles) desktop <## "ok" @@ -456,8 +462,10 @@ remoteCLIFileTest = testRemote3 $ \compress mobile desktop bob -> withXFTPServer [ do bob <## "completed uploading file 1 (test.pdf) for alice", do - desktop <## "saving file 1 from bob to test.pdf" - desktop <## "started receiving file 1 (test.pdf) from bob" + desktop + <### [ "saving file 1 from bob to test.pdf", + "started receiving file 1 (test.pdf) from bob" + ] desktop <## "completed receiving file 1 (test.pdf) from bob" ] @@ -482,8 +490,10 @@ remoteCLIFileTest = testRemote3 $ \compress mobile desktop bob -> withXFTPServer [ do desktop <## "completed uploading file 2 (test.jpg) for bob", do - bob <## "saving file 2 from alice to ./tests/tmp/bob_files/test.jpg" - bob <## "started receiving file 2 (test.jpg) from alice" + bob + <### [ ConsoleString ("saving file 2 from alice to " <> bobFiles <> "test.jpg"), + "started receiving file 2 (test.jpg) from alice" + ] bob <## "completed receiving file 2 (test.jpg) from alice" ] diff --git a/tests/SchemaDump.hs b/tests/SchemaDump.hs index 783f6587bf..0f2cddcc1c 100644 --- a/tests/SchemaDump.hs +++ b/tests/SchemaDump.hs @@ -5,7 +5,6 @@ module SchemaDump where -import ChatClient (withTmpFiles) import ChatTests.DBUtils import Control.Concurrent.STM import Control.DeepSeq @@ -62,7 +61,7 @@ schemaDumpTest = do it "verify strict tables" testVerifyStrict testVerifySchemaDump :: IO () -testVerifySchemaDump = withTmpFiles $ do +testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () void $ createChatStore (DBOpts testDB chatDBFunctions "" False True TQOff) (MigrationConfig MCError Nothing) @@ -70,7 +69,7 @@ testVerifySchemaDump = withTmpFiles $ do removeFile testDB testVerifyLintFKeyIndexes :: IO () -testVerifyLintFKeyIndexes = withTmpFiles $ do +testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () void $ createChatStore (DBOpts testDB chatDBFunctions "" False True TQOff) (MigrationConfig MCError Nothing) @@ -78,7 +77,7 @@ testVerifyLintFKeyIndexes = withTmpFiles $ do removeFile testDB testSchemaMigrations :: IO () -testSchemaMigrations = withTmpFiles $ do +testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Store.migrations Right st <- createDBStore (DBOpts testDB chatDBFunctions "" False True TQOff) noDownMigrations (MigrationConfig MCError Nothing) mapM_ (testDownMigration st) $ drop (length noDownMigrations) Store.migrations diff --git a/tests/Test.hs b/tests/Test.hs index 0a5b56b230..4517a8edb2 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -31,15 +31,17 @@ import OperatorTests import RandomServers import RemoteTests import Test.Hspec hiding (it) +#if !MIN_VERSION_hspec(2,10,10) +import Test.Hspec.Core.Spec (sequential) +#endif import UnliftIO.Temporary (withTempDirectory) import ValidNames import ViewTests #if defined(dbPostgres) -import Control.Exception (bracket_) +import Control.Exception (bracket_, finally) import PostgresSchemaDump import Simplex.Chat.Store.Postgres.Migrations (migrations) import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) -import System.Directory (createDirectoryIfMissing, removePathForcibly) #else import APIDocs import qualified Simplex.Messaging.TMap as TM @@ -55,19 +57,20 @@ main = do chatQueryStats <- TM.emptyIO agentQueryStats <- TM.emptyIO #endif - withGlobalLogging logCfg . hspec + portBases <- newPortBases + withTestDB . withTmpFiles . withGlobalLogging logCfg . hspec . parallel $ do #if defined(dbPostgres) - createdDropDb . around_ (bracket_ (createDirectoryIfMissing False "tests/tmp") (removePathForcibly "tests/tmp")) $ + sequential $ describe "Postgres schema dump" $ postgresSchemaDumpTest migrations schemaDumpDBOpts "src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql" #else - describe "Schema dump" schemaDumpTest + sequential $ describe "Schema dump" schemaDumpTest #if MIN_VERSION_base(4,18,0) - describe "Bot API docs" apiDocsTest + sequential $ describe "Bot API docs" apiDocsTest #endif around tmpBracket $ describe "WebRTC encryption" webRTCTests #endif @@ -90,13 +93,13 @@ main = do describe "Operators" operatorTests describe "Random servers" randomServersTests #if !defined(dbPostgres) - around (tmpTestBracket chatQueryStats agentQueryStats) $ describe "names tests" chatNamesTests - around (tmpTestBracket chatQueryStats agentQueryStats) $ xdescribe'' "SimpleX Directory names" directoryNameTests + around (tmpTestBracket chatQueryStats agentQueryStats portBases) $ describe "names tests" chatNamesTests + around (tmpTestBracket chatQueryStats agentQueryStats portBases) $ describe "SimpleX Directory names" directoryNameTests #endif #if defined(dbPostgres) - createdDropDb . around testBracket + around (testBracket portBases) #else - around (testBracket chatQueryStats agentQueryStats) + around (testBracket chatQueryStats agentQueryStats portBases) #endif $ do #if !defined(dbPostgres) @@ -104,30 +107,35 @@ main = do #endif describe "SimpleX chat client" chatTests xdescribe'' "SimpleX Broadcast bot" broadcastBotTests - xdescribe'' "SimpleX Directory service bot" directoryServiceTests - xdescribe'' "SimpleX badge service e2e" $ do + describe "SimpleX Directory service bot" directoryServiceTests + describe "SimpleX badge service e2e" $ do badgeServiceTests describe "managed group" badgeGroupIntegrationTests describe "Remote session" remoteTests #if !defined(dbPostgres) - xdescribe'' "Save query plans" saveQueryPlans + sequential $ xdescribe'' "Save query plans" saveQueryPlans #endif where #if defined(dbPostgres) - createdDropDb = - before_ (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) - . after_ (dropDatabaseAndUser testDBConnectInfo) - testBracket test = withSmpServer $ tmpBracket $ \tmpPath -> test TestParams {tmpPath, printOutput = False} + withTestDB = + bracket_ + (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) + (dropDatabaseAndUser testDBConnectInfo) + testBracket portBases test = + withPortBase portBases $ \portBase -> tmpBracket $ \tmpPath -> do + let ps = TestParams {tmpPath, portBase, printOutput = False} + withSmpServer ps (test ps) `finally` dropTestSchemas ps #else - testBracket chatQueryStats agentQueryStats test = - withSmpServer $ tmpBracket $ \tmpPath -> test TestParams {tmpPath, chatQueryStats, agentQueryStats, printOutput = False} - tmpTestBracket chatQueryStats agentQueryStats test = - tmpBracket $ \tmpPath -> test TestParams {tmpPath, chatQueryStats, agentQueryStats, printOutput = False} + withTestDB = id + testBracket chatQueryStats agentQueryStats portBases test = + tmpTestBracket chatQueryStats agentQueryStats portBases $ \ps -> withSmpServer ps $ test ps + tmpTestBracket chatQueryStats agentQueryStats portBases test = + withPortBase portBases $ \portBase -> tmpBracket $ \tmpPath -> test TestParams {tmpPath, portBase, chatQueryStats, agentQueryStats, printOutput = False} #endif tmpBracket test = do t <- getSystemTime let ts = show (systemSeconds t) <> show (systemNanoseconds t) - withTmpFiles $ withTempDirectory "tests/tmp" ts test + withTempDirectory "tests/tmp" ts test logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}