dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-15 04:30:38 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into ep/profile-badges

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-10-08 08:58:38 +00:00
parent 0f6b833125 40478c1c45
commit 6e505952b2
42 changed files with 1643 additions and 1179 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.github/workflows/build.yml
+8
View File
@@ -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
apps/multiplatform/android/build.gradle.kts
+2 -2
View File
@@ -9,13 +9,13 @@ plugins {
}
android {
compileSdk = 35
compileSdk = 36
defaultConfig {
applicationId = "chat.simplex.app"
namespace = "chat.simplex.app"
minSdk = 26
targetSdk = 35
targetSdk = 36
// !!!
// skip version code after release to F-Droid, as it uses two version codes
versionCode = (extra["android.version_code"] as String).toInt()
apps/multiplatform/android/src/main/AndroidManifest.xml
+5 -1
View File
@@ -35,6 +35,8 @@
</intent>
</queries>
<!-- enableOnBackInvokedCallback="false": Activity.onBackPressed() overrides are not called on Android 16+ without it.
UnusedAttribute is ignored because the attribute only exists on API 33+, older versions call onBackPressed() anyway -->
<application
android:name="SimplexApp"
android:allowBackup="false"
@@ -44,7 +46,9 @@
android:largeHeap="true"
android:extractNativeLibs="${extract_native_libs}"
android:supportsRtl="true"
android:theme="@style/Theme.SimpleX">
android:enableOnBackInvokedCallback="false"
android:theme="@style/Theme.SimpleX"
tools:ignore="UnusedAttribute">
<!-- android:localeConfig="@xml/locales_config"-->
<!-- Main activity -->
apps/multiplatform/common/build.gradle.kts
+3 -3
View File
@@ -158,13 +158,13 @@ kotlin {
android {
namespace = "chat.simplex.common"
compileSdk = 35
compileSdk = 36
sourceSets["main"].manifest.srcFile("src/androidMain/AndroidManifest.xml")
defaultConfig {
minSdk = 26
}
testOptions.targetSdk = 34
lint.targetSdk = 34
testOptions.targetSdk = 36
lint.targetSdk = 36
val isAndroid = gradle.startParameter.taskNames.find {
val lower = it.lowercase()
lower.contains("release") || lower.startsWith("assemble") || lower.startsWith("install")
apps/multiplatform/gradle.properties
+1 -1
View File
@@ -31,7 +31,7 @@ desktop.version_name=7.1-beta.6
desktop.version_code=167
kotlin.version=2.1.20
gradle.plugin.version=8.7.0
gradle.plugin.version=8.10.1
compose.version=1.8.2
# Choose sqlite or postgres backend
apps/simplex-directory-service/Main.hs
+1 -1
View File
@@ -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
apps/simplex-directory-service/src/Directory/Events.hs
+7
View File
@@ -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
apps/simplex-directory-service/src/Directory/Service.hs
+7 -6
View File
@@ -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 "<ID>"
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
cabal.project
+1 -1
View File
@@ -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
plans/2026-09-13-parallel-tests.md
+81
View File
@@ -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.
scripts/nix/sha256map.nix
+1 -1
View File
@@ -1,7 +1,7 @@
{
"https://github.com/simplex-chat/simplexmq.git"."c7575ddfd2c0196b6eb1f9d0c1c59988c02dfb6d" = "0qy9jjg6vizh77vhm4xvnb7sfqpmb7d53zspmk7a4mkbv48354kz";
"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";
simplex-chat.cabal
+2 -1
View File
@@ -781,7 +781,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.*
@@ -844,5 +844,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
src/Simplex/Chat/Core.hs
+17 -11
View File
@@ -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
src/Simplex/Chat/Library/Subscriber.hs
+7 -10
View File
@@ -658,7 +658,6 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
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
@@ -673,6 +672,7 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
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'
@@ -888,7 +888,6 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
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
@@ -902,10 +901,14 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
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
@@ -2909,7 +2912,7 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
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 presHeader_ rcvProfile
unless (muteEventInChannel gInfo m') $ do
@@ -2918,12 +2921,6 @@ processAgentMessageConn cxt user@User {userId} entity gInfoKeys_ corrId agentCon
toView $ CEvtContactUpdated user mCt ct'
pure m'
else withStore' $ \db -> setMemberBadgeProof db m presHeader_ rcvProfile
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
src/Simplex/Chat/Store/Direct.hs
+1 -1
View File
@@ -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"
src/Simplex/Chat/Store/Groups.hs
+21 -7
View File
@@ -3121,10 +3121,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|
@@ -3428,7 +3428,16 @@ setMemberContactStartedConnection db Contact {contactId} = do
(BI True, currentTs, contactId)
updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO GroupMember
updateMemberProfile db cxt user@User {userId} m presHeader_ p = do
updateMemberProfile db cxt user m@GroupMember {memberContactId} presHeader_ p = case memberContactId of
Nothing -> updateUnlinkedMemberProfile db cxt user m presHeader_ p
Just ctId -> do
ct <- getContact db cxt user ctId
if contactUpdatableFromMember ct
then fst <$> updateContactMemberProfile db cxt user m ct presHeader_ p
else liftIO $ setMemberBadgeProof db m presHeader_ p
updateUnlinkedMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO GroupMember
updateUnlinkedMemberProfile db cxt user@User {userId} m presHeader_ p = do
currentTs <- liftIO getCurrentTime
(p', badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) (Just $ memberProfile m) p
let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing
@@ -3538,8 +3547,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 Nothing currentTs
(localDisplayName, profileId) <- maybe (newOwnerProfile currentTs) contactNameAndProfile contactId_
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $
DB.execute
@@ -3559,6 +3567,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
@@ -3694,7 +3708,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"
src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt
+4
View File
@@ -1402,6 +1402,10 @@ Query: SELECT conn_id, rc_verify_code_ad, rc_verify_code_pq, CASE WHEN rc_verify
Plan:
SEARCH ratchets USING PRIMARY KEY (conn_id=?)
Query: SELECT count(1) FROM commands
Plan:
SCAN commands USING COVERING INDEX idx_commands_conn_id
Query: SELECT count(1) FROM connections
Plan:
SCAN connections USING COVERING INDEX idx_connections_deleted
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+36 -20
View File
@@ -1135,6 +1135,15 @@ SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH h USING INDEX idx_sent_probe_hashes_sent_probe_id (sent_probe_id=?)
Query:
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 = ?
Plan:
SCAN s
SEARCH r USING AUTOMATIC PARTIAL COVERING INDEX (local_display_name=?)
Query:
SELECT t.roster_transfer_id, t.roster_version, t.roster_digest, t.sending_owner_gm_id, t.broker_ts,
t.roster_msg_chat_binding, t.roster_msg_signatures, t.roster_msg_body
@@ -1849,11 +1858,15 @@ SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query:
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 = ?
Plan:
MULTI-INDEX OR
INDEX 1
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
INDEX 2
SEARCH group_members USING INDEX idx_group_members_contact_id (contact_id=?)
Query:
UPDATE group_members
@@ -4213,15 +4226,6 @@ SEARCH c USING INTEGER PRIMARY KEY (rowid=?)
SEARCH cs USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
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 = ?
Plan:
SCAN s
SEARCH r USING AUTOMATIC PARTIAL COVERING INDEX (local_display_name=?)
Query:
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled,
role_storage, role_proxy, role_names
@@ -7364,6 +7368,10 @@ Query: SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND ms
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_msg_content_tag_deleted (user_id=? AND group_id=? AND msg_content_tag=? AND item_deleted=? AND item_sent=?)
Query: SELECT COUNT(1) FROM commands WHERE command_function = 'set_short_link'
Plan:
SCAN commands
Query: SELECT COUNT(1) FROM contacts WHERE user_id = ? AND chat_item_ttl > 0
Plan:
SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
@@ -7464,11 +7472,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
@@ -7548,9 +7552,9 @@ Query: SELECT connection_id FROM connections WHERE user_id = ? AND group_member_
Plan:
SEARCH connections USING INDEX idx_connections_group_member_id (group_member_id=?)
Query: SELECT contact_id FROM contacts WHERE user_id = ? AND chat_item_ttl > 0 OR chat_item_ttl IS NULL
Query: SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0 OR chat_item_ttl IS NULL)
Plan:
SCAN contacts
SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
Query: SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0
Plan:
@@ -7646,9 +7650,9 @@ Query: SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMI
Plan:
SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
Query: SELECT group_id FROM groups WHERE user_id = ? AND chat_item_ttl > 0 OR chat_item_ttl IS NULL
Query: SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0 OR chat_item_ttl IS NULL)
Plan:
SCAN groups
SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
Query: SELECT group_id FROM groups WHERE user_id = ? AND creating_in_progress = 1 AND created_at <= ?
Plan:
@@ -7686,6 +7690,10 @@ Query: SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1
Plan:
SEARCH contact_profiles USING INDEX contact_profiles_index (display_name=?)
Query: SELECT index_in_group, member_relations_vector FROM group_members WHERE local_display_name = ?
Plan:
SCAN group_members
Query: SELECT issue_failed_since, issue_error FROM badge_purchases
Plan:
SCAN badge_purchases
@@ -7766,6 +7774,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=?)
@@ -7838,6 +7850,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=?)
src/Simplex/Chat/Types.hs
+7
View File
@@ -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
tests/Bots/BadgeService/BotTests.hs
+72 -40
View File
@@ -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 <name> [<bio>] 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 =
tests/Bots/BadgeService/GroupIntegrationTests.hs
+5 -2
View File
@@ -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 =
tests/Bots/BadgeService/WebTests.hs
+27 -16
View File
@@ -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
tests/Bots/BroadcastTests.hs
+9 -7
View File
@@ -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
tests/Bots/DirectoryTests.hs
+244 -225
View File
@@ -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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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' <message> 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
tests/ChatClient.hs
+124 -39
View File
@@ -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
)
tests/ChatTests/ChatRelays.hs
+1 -3
View File
@@ -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 =
tests/ChatTests/DBUtils/Postgres.hs
+1
View File
@@ -2,5 +2,6 @@ module ChatTests.DBUtils.Postgres where
data TestParams = TestParams
{ tmpPath :: FilePath,
portBase :: Int,
printOutput :: Bool
}
tests/ChatTests/DBUtils/SQLite.hs
+1
View File
@@ -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
tests/ChatTests/Direct.hs
+132 -126
View File
@@ -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"
@@ -1169,27 +1170,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"
@@ -1210,16 +1211,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 ()
@@ -1279,11 +1280,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
@@ -1297,11 +1296,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}}
@@ -1346,7 +1343,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"
@@ -1355,7 +1352,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"
@@ -1371,7 +1368,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
@@ -1409,6 +1406,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)
@@ -1444,12 +1442,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
@@ -1467,13 +1465,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
@@ -1494,14 +1492,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"
@@ -1509,32 +1506,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
@@ -1552,7 +1555,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
@@ -1561,7 +1564,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 ""
@@ -1570,14 +1573,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 ()
@@ -1603,8 +1609,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"
@@ -1619,8 +1625,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"
@@ -1760,6 +1766,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')"
@@ -1786,9 +1793,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
@@ -1796,10 +1801,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
@@ -1809,11 +1816,13 @@ testSubscribeAppNSE ps =
bob <## "connection request sent!"
(nseAlice </)
alice ##> "/_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_
@@ -2039,7 +2048,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}")
@@ -2064,7 +2073,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
@@ -2350,17 +2359,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"
@@ -2372,7 +2381,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"
@@ -2381,22 +2390,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}
@@ -2405,13 +2414,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
@@ -2443,7 +2452,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"
@@ -2455,7 +2464,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"
@@ -2464,22 +2473,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}
@@ -2565,7 +2574,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
@@ -2577,7 +2586,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"
@@ -2586,17 +2595,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"
@@ -2605,10 +2614,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}
@@ -2617,13 +2626,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"
@@ -2644,7 +2653,7 @@ testUsersTimedMessages ps' = do
alice <# "bob> alisa 2"
-- messages are deleted after ttl
threadDelay 1500000
threadDelay 6000000
alice ##> "/user alice"
showActiveUser alice "alice (Alice)"
@@ -2654,7 +2663,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"]
@@ -2667,7 +2676,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"]
@@ -2707,7 +2716,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"]
@@ -2720,7 +2729,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"]
@@ -2886,15 +2895,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"
@@ -2902,17 +2911,17 @@ testSetChatItemTTL =
bob <## "use /fr 1 [<dir>/ | <path>] 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")
@@ -2936,13 +2945,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")])
@@ -3023,8 +3032,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 ()
@@ -3043,8 +3052,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"
@@ -3052,8 +3060,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 ()
@@ -3067,8 +3075,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"
@@ -3090,8 +3098,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"
@@ -3099,8 +3106,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"
@@ -3222,8 +3229,7 @@ setupDesynchronizedRatchet ps alice = do
alice #> "@bob 2"
alice #> "@bob 3"
(bob </)
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 </)
@@ -3253,8 +3259,8 @@ testSyncRatchet ps =
bob <## "alice: connection synchronized"
threadDelay 100000
bob #$> ("/_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"
@@ -3293,8 +3299,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"
tests/ChatTests/Files.hs
+222 -191
View File
File diff suppressed because it is too large Load Diff
tests/ChatTests/Forward.hs
+57 -53
View File
@@ -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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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
tests/ChatTests/Groups.hs
+241 -189
View File
File diff suppressed because it is too large Load Diff
tests/ChatTests/Local.hs
+10 -9
View File
@@ -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
tests/ChatTests/Names.hs
+11 -11
View File
@@ -31,7 +31,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" [])
@@ -183,7 +183,7 @@ checkNoName bob = do
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" [])
@@ -196,7 +196,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" [])
@@ -219,7 +219,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
@@ -228,7 +228,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" [])
@@ -244,7 +244,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
@@ -264,7 +264,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
@@ -294,7 +294,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
@@ -328,7 +328,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
@@ -367,7 +367,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
@@ -386,7 +386,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
tests/ChatTests/Profiles.hs
+175 -139
View File
@@ -1341,26 +1341,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 ()
@@ -1404,8 +1404,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
}
@@ -1461,7 +1461,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
@@ -1864,9 +1864,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"
]
@@ -1886,11 +1887,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"
@@ -1924,6 +1922,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 <message> 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
@@ -2006,8 +2017,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...)"
@@ -2019,6 +2032,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 <message> to send messages"
biz #> "#alisa hey"
concurrentlyN_
[ do
@@ -2029,10 +2044,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 <message> to send messages"
cath <# "#alisa business> hey"
cath <# "#alisa business> hey"
]
biz ##> "/set delete #alisa on"
biz <## "updated group preferences:"
@@ -2104,10 +2116,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"
@@ -2156,10 +2170,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
@@ -2536,8 +2552,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"]
@@ -3116,12 +3134,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
@@ -3143,9 +3161,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
}
@@ -3183,13 +3202,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:"
@@ -3308,8 +3327,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"
@@ -3319,8 +3337,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"
@@ -3328,8 +3345,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
@@ -3382,7 +3398,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")])
@@ -3451,41 +3467,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))"
@@ -3495,23 +3511,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:"
@@ -3523,8 +3539,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:"
@@ -3546,20 +3562,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 $
@@ -3659,13 +3675,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"
@@ -3694,7 +3710,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"
@@ -3957,9 +3973,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"
@@ -3999,10 +4016,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"
@@ -4029,15 +4049,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 = 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"
@@ -4061,17 +4085,20 @@ testShortLinkInvitationConnectRetry ps = testChatCfgOpts2 cfg' opts' aliceProfil
<### [ "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
}
cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}}
@@ -4244,8 +4271,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
}
cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}}
@@ -4280,10 +4307,10 @@ testShortLinkAddressConnectRetryIncognito ps =
bob <## "contact address: known prepared contact alice"
bob ##> "/_connect contact @2 incognito=on text hello"
line <- getTermLine bob
bobIncognito <-
if "i @alice hello" `isSuffixOf` line
then getTermLine bob <* bob <## "alice: connection started incognito"
else line <$ bob <### ["alice: connection started incognito", WithTime "i @alice hello"]
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")
@@ -4308,8 +4335,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
}
cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}}
@@ -4340,11 +4367,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"
@@ -4565,10 +4589,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"
@@ -4591,8 +4615,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' =
@@ -4689,10 +4713,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
@@ -4741,10 +4768,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"
@@ -4945,13 +4975,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"
@@ -4992,13 +5022,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")
@@ -5037,10 +5068,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 ()
@@ -5178,11 +5212,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"
tests/ChatTests/Utils.hs
+29 -10
View File
@@ -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
@@ -36,7 +36,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
@@ -46,8 +46,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
@@ -98,7 +97,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
@@ -683,11 +682,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
@@ -861,8 +873,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"),
@@ -937,7 +951,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
tests/RemoteTests.hs
+32 -22
View File
@@ -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"
]
tests/SchemaDump.hs
+3 -4
View File
@@ -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
tests/Test.hs
+30 -22
View File
@@ -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}
website/src/crowdfunding.html
+5 -5
View File
@@ -1033,7 +1033,7 @@ templateEngineOverride: njk
</div>
<div class="cf-stat">
<img src="/img/crowdfunding/p2p.png" alt="">
<div><b>520K</b><span>Monthly users</span></div>
<div><b>600K</b><span>Monthly users</span></div>
</div>
</div>
</div>
@@ -1048,8 +1048,8 @@ templateEngineOverride: njk
<section class="page cf cf-light cf-left cf-growth" data-section="growth">
<div class="area">
<div class="text-container">
<h2>520,000<br>monthly users</h2>
<p>Grown with <span>zero marketing spend</span>: hundreds of user posts, podcasts and videos, and <span>$650,000 in user donations</span>, before any paid features.</p>
<h2>Over 600,000<br>monthly users</h2>
<p><span>Organic growth</span>: hundreds of user posts, podcasts and videos, and <span>$650,000 in user donations</span>, before any paid features.</p>
<p>Only <span>$1.7M investment over 4 years</span> &mdash; more capital efficient than most startups.</p>
</div>
</div>
@@ -1074,7 +1074,7 @@ templateEngineOverride: njk
<img class="cf-tags-art" src="/img/design_3/section-3-mobile-light.webp" alt="">
<div class="cf-tag" style="left: 40.8%; top: 70.1%;">
<div class="n">Users</div>
<div class="v"><b>520,000</b> active monthly,</div>
<div class="v"><b>600,000</b> active monthly,</div>
<div class="v">organic growth</div>
</div>
<div class="cf-tag" style="left: 45.8%; top: 47.6%;">
@@ -1084,7 +1084,7 @@ templateEngineOverride: njk
</div>
<div class="cf-tag" style="left: 45.2%; top: 30%;">
<div class="n">Businesses</div>
<div class="v"><b>20+</b> offer customer</div>
<div class="v"><b>50+</b> offer customer</div>
<div class="v">support</div>
</div>
<div class="cf-tag" style="left: 31.9%; top: 29.4%;">
website/src/img/crowdfunding/simplex-chat-pitch-deck.pdf
BIN
View File
Binary file not shown.
website/src/img/crowdfunding/simplex-growth-2.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 215 KiB

After

Width:  |  Height:  |  Size: 237 KiB