dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-27 17:58:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

tests: execute in parallel

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-09-13 11:35:46 +00:00
parent ca114a7a2a
commit 1e2f0bec79
18 changed files with 750 additions and 530 deletions
Download Patch File Download Diff File Expand all files Collapse all files
plans/2026-09-13-parallel-tests.md
+71
View File
@@ -0,0 +1,71 @@
# 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.
## 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.
simplex-chat.cabal
+1 -2
View File
@@ -660,7 +660,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.*
@@ -682,7 +682,6 @@ test-suite simplex-chat-test
, network ==3.1.*
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, silently ==1.2.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=6.3
tests/Bots/BroadcastTests.hs
+1 -1
View File
@@ -43,7 +43,7 @@ mkBotOpts ps publishers =
{ dbOptions =
(dbOptions testCoreOpts)
#if defined(dbPostgres)
{dbSchemaPrefix = "client_" <> botDbPrefix}
{dbSchemaPrefix = testSchemaPrefix ps botDbPrefix}
#else
{dbFilePrefix = tmpPath ps </> botDbPrefix}
#endif
tests/Bots/DirectoryTests.hs
+18 -16
View File
@@ -112,16 +112,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
{ dbOptions =
(dbOptions testCoreOpts)
#if defined(dbPostgres)
{dbSchemaPrefix = "client_" <> serviceDbPrefix}
{dbSchemaPrefix = testSchemaPrefix ps serviceDbPrefix}
#else
{dbFilePrefix = ps </> serviceDbPrefix}
{dbFilePrefix = tmpPath ps </> serviceDbPrefix}
#endif
},
@@ -1155,13 +1155,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
@@ -1169,9 +1169,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"
@@ -1181,14 +1181,14 @@ 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)"
@@ -1200,21 +1200,23 @@ testListUserGroups promote ps =
superUser <## ""
superUser <## "To approve send:"
superUser <# "'SimpleX Directory'> /approve 1:privacy 1 promote=on"
checkListings ["security"] []
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 webDir ["privacy", "security"] ["privacy"]
where
webDir = tmpFile ps "web"
checkListings :: HasCallStack => [T.Text] -> [T.Text] -> IO ()
checkListings listed promoted = do
checkListings :: HasCallStack => FilePath -> [T.Text] -> [T.Text] -> IO ()
checkListings webDir listed promoted = do
threadDelay 100000
checkListing listingFileName listed
checkListing promotedFileName promoted
where
checkListing f expected = do
Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web/data" </> f
Just (DirectoryListing gs) <- J.decodeFileStrict $ webDir </> "data" </> f
map groupName gs `shouldBe` expected
groupName DirectoryEntry {displayName} = displayName
@@ -2148,7 +2150,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
@@ -2189,7 +2191,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
tests/ChatClient.hs
+118 -35
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)
@@ -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 =
@@ -201,7 +264,8 @@ data TestCC = TestCC
chatAsync :: Async (),
termAsync :: Async (),
termQ :: TQueue String,
printOutput :: Bool
printOutput :: Bool,
ccParams :: TestParams
}
aCfg :: AgentConfig
@@ -291,8 +355,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")
@@ -305,7 +378,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_
t <- withVirtualTerminal termSettings pure
ct <- newChatTerminal t opts
Right cc <- newChatController db (Just user) cfg opts False
@@ -314,7 +388,7 @@ startTestChat_ TestParams {tmpPath, printOutput} db cfg opts@ChatOpts {coreOptio
unless maintenance $ atomically $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
termQ <- newTQueueIO
termAsync <- async $ readTerminalOutput t termQ
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ, printOutput}
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ, printOutput, ccParams = ps}
stopTestChat :: TestParams -> TestCC -> IO ()
stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}, chatAsync, termAsync} = do
@@ -437,6 +511,16 @@ withTmpFiles =
(createDirectoryIfMissing False "tests/tmp")
(removeDirectoryRecursive "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 =
bracket (getTestCCs $ zip ps [1 ..]) endTests test
@@ -474,7 +558,7 @@ getTermLine' expected cc@TestCC {printOutput} =
error $ name <> ": no output for 5 seconds" <> expectedMsg
userName :: TestCC -> IO [Char]
userName (TestCC ChatController {currentUser} _ _ _ _ _) =
userName TestCC {chatController = ChatController {currentUser}} =
maybe "no current user" (\User {localDisplayName} -> T.unpack localDisplayName) <$> readTVarIO currentUser
testChat :: HasCallStack => Profile -> (HasCallStack => TestCC -> IO ()) -> TestParams -> IO ()
@@ -548,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,
@@ -603,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,
@@ -653,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/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
+39 -34
View File
@@ -267,8 +267,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
}
@@ -301,7 +301,7 @@ 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
@@ -330,8 +330,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
}
@@ -1129,9 +1129,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"
@@ -1154,27 +1154,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"
@@ -1195,16 +1195,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 ()
@@ -1369,7 +1369,7 @@ 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"
@@ -1384,16 +1384,18 @@ 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
@@ -1404,12 +1406,12 @@ testChatWorking alice bob = do
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
@@ -1427,26 +1429,29 @@ 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
alice ##> "/_stop"
alice <## "chat stopped"
alice ##> "/_db export {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}"
alice ##> ("/_db export {\"archivePath\": \"" <> archive <> "\"}")
alice <## "ok"
alice ##> "/_db delete"
alice <## "ok"
-- cannot start chat after delete
alice ##> "/_start"
alice <## "error: chat store changed, please restart chat"
doesDirectoryExist "./tests/tmp/alice_files" `shouldReturn` False
alice ##> "/_db import {\"archivePath\": \"./tests/tmp/alice-chat.zip\"}"
doesDirectoryExist aliceFiles `shouldReturn` False
alice ##> ("/_db import {\"archivePath\": \"" <> archive <> "\"}")
alice <## "ok"
B.readFile "./tests/tmp/alice_files/test.jpg" `shouldReturn` src
B.readFile (aliceFiles </> "test.jpg") `shouldReturn` src
-- 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 ()
@@ -2755,15 +2760,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"
@@ -2777,7 +2782,7 @@ testSetChatItemTTL =
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" $
checkActionDeletesFile (tmpFile alice "app_files/test.jpg") $
alice #$> ("/_ttl 1 2", 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")])
tests/ChatTests/Files.hs
+214 -187
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
+112 -101
View File
@@ -2002,7 +2002,7 @@ testGroupDelayedModerationFullDelete ps = do
testDeleteMemberWithMessages :: HasCallStack => TestParams -> IO ()
testDeleteMemberWithMessages =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
\alice bob cath -> withXFTPServer alice $ do
createGroup3' "team" alice (bob, GRMember) (cath, GRMember)
threadDelay 750000
alice ##> "/set delete #team on"
@@ -2021,10 +2021,13 @@ testDeleteMemberWithMessages =
]
threadDelay 750000
alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok")
bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok")
cath #$> ("/_files_folder ./tests/tmp/cath_app_files", id, "ok")
copyFile "./tests/fixtures/test.jpg" "./tests/tmp/bob_app_files/test.jpg"
let aliceFiles = tmpFile alice "alice_app_files"
bobFiles = tmpFile bob "bob_app_files"
cathFiles = tmpFile cath "cath_app_files"
alice #$> ("/_files_folder " <> aliceFiles, id, "ok")
bob #$> ("/_files_folder " <> bobFiles, id, "ok")
cath #$> ("/_files_folder " <> cathFiles, id, "ok")
copyFile "./tests/fixtures/test.jpg" (bobFiles </> "test.jpg")
bob ##> "/_send #1 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"file from bob\"}}]"
bob <# "#team file from bob"
@@ -2056,9 +2059,9 @@ testDeleteMemberWithMessages =
cath <## "completed receiving file 1 (test.jpg) from bob"
src <- B.readFile "./tests/fixtures/test.jpg"
B.readFile "./tests/tmp/alice_app_files/test.jpg" `shouldReturn` src
B.readFile "./tests/tmp/bob_app_files/test.jpg" `shouldReturn` src
B.readFile "./tests/tmp/cath_app_files/test.jpg" `shouldReturn` src
B.readFile (aliceFiles </> "test.jpg") `shouldReturn` src
B.readFile (bobFiles </> "test.jpg") `shouldReturn` src
B.readFile (cathFiles </> "test.jpg") `shouldReturn` src
threadDelay 1000000
alice ##> "/rm #team bob messages=on"
@@ -2067,9 +2070,9 @@ testDeleteMemberWithMessages =
bob <## "use /d #team to delete the group"
cath <## "#team: alice removed bob from the group with all messages (signed)"
doesFileExist "./tests/tmp/alice_app_files/test.jpg" `shouldReturn` False
doesFileExist "./tests/tmp/bob_app_files/test.jpg" `shouldReturn` False
doesFileExist "./tests/tmp/cath_app_files/test.jpg" `shouldReturn` False
doesFileExist (aliceFiles </> "test.jpg") `shouldReturn` False
doesFileExist (bobFiles </> "test.jpg") `shouldReturn` False
doesFileExist (cathFiles </> "test.jpg") `shouldReturn` False
-- Under fullDelete, bob's items are physically deleted on all sides; only the system event remains.
alice #$> ("/_get chat #1 count=1", chat, [(1, "removed bob (signed)")])
@@ -2265,8 +2268,8 @@ testSharedMessageBody ps' =
ps = ps' {printOutput = True} :: TestParams
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -2319,8 +2322,8 @@ testSharedBatchBody ps =
where
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -2524,8 +2527,8 @@ testSharedBatchBodyMixed ps =
oldCfg = testCfg {chatVRange = mkVersionRange (VersionChat 9) (VersionChat 17)}
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -5614,7 +5617,7 @@ testGroupMsgForwardDeletion =
testGroupMsgForwardFile :: HasCallStack => TestParams -> IO ()
testGroupMsgForwardFile =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
\alice bob cath -> withXFTPServer alice $ do
createGroup3 "team" alice bob cath
setupGroupForwarding alice bob cath
@@ -5629,12 +5632,12 @@ testGroupMsgForwardFile =
cath <# "#team bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]"
]
cath ##> "/fr 1 ./tests/tmp"
cath <## "saving file 1 from bob to ./tests/tmp/test.jpg"
cath ##> ("/fr 1 " <> tmpDir cath)
cath <## ("saving file 1 from bob to " <> tmpFile cath "test.jpg")
cath <## "started receiving file 1 (test.jpg) from bob"
cath <## "completed receiving file 1 (test.jpg) from bob"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest <- B.readFile (tmpFile cath "test.jpg")
dest `shouldBe` src
testGroupMsgForwardChangeRole :: HasCallStack => TestParams -> IO ()
@@ -5986,7 +5989,7 @@ testGroupHistoryPreferenceOff =
testGroupHistoryHostFile :: HasCallStack => TestParams -> IO ()
testGroupHistoryHostFile =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
\alice bob cath -> withXFTPServer alice $ do
createGroup2 "team" alice bob
alice #> "/f #team ./tests/fixtures/test.jpg"
@@ -6012,20 +6015,20 @@ testGroupHistoryHostFile =
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir cath)
cath
<### [ "saving file 1 from alice to ./tests/tmp/test.jpg",
<### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile cath "test.jpg",
"started receiving file 1 (test.jpg) from alice"
]
cath <## "completed receiving file 1 (test.jpg) from alice"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest <- B.readFile (tmpFile cath "test.jpg")
dest `shouldBe` src
testGroupHistoryMemberFile :: HasCallStack => TestParams -> IO ()
testGroupHistoryMemberFile =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
\alice bob cath -> withXFTPServer alice $ do
createGroup2 "team" alice bob
bob #> "/f #team ./tests/fixtures/test.jpg"
@@ -6051,27 +6054,28 @@ testGroupHistoryMemberFile =
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir cath)
cath
<### [ "saving file 1 from bob to ./tests/tmp/test.jpg",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "test.jpg",
"started receiving file 1 (test.jpg) from bob"
]
cath <## "completed receiving file 1 (test.jpg) from bob"
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest <- B.readFile (tmpFile cath "test.jpg")
dest `shouldBe` src
testGroupHistoryLargeFile :: HasCallStack => TestParams -> IO ()
testGroupHistoryLargeFile =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile"]
\alice bob cath -> withXFTPServer alice $ do
let testfile = tmpFile bob "testfile"
xftpCLI ["rand", testfile, "17mb"] `shouldReturn` ["File created: " <> testfile]
createGroup2 "team" alice bob
bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}]"
bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfile <> "\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}]")
bob <# "#team hello"
bob <# "/f #team ./tests/tmp/testfile"
bob <# ("/f #team " <> testfile)
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile) for #team"
@@ -6080,14 +6084,14 @@ testGroupHistoryLargeFile =
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
-- admin receiving file does not prevent the new member from receiving it later
alice ##> "/fr 1 ./tests/tmp"
alice ##> ("/fr 1 " <> tmpDir alice)
alice
<### [ "saving file 1 from bob to ./tests/tmp/testfile_1",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile alice "testfile_1",
"started receiving file 1 (testfile) from bob"
]
alice <## "completed receiving file 1 (testfile) from bob"
src <- B.readFile "./tests/tmp/testfile"
destAlice <- B.readFile "./tests/tmp/testfile_1"
src <- B.readFile testfile
destAlice <- B.readFile (tmpFile alice "testfile_1")
destAlice `shouldBe` src
connectUsers alice cath
@@ -6107,14 +6111,14 @@ testGroupHistoryLargeFile =
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir cath)
cath
<### [ "saving file 1 from bob to ./tests/tmp/testfile_2",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "testfile_2",
"started receiving file 1 (testfile) from bob"
]
cath <## "completed receiving file 1 (testfile) from bob"
destCath <- B.readFile "./tests/tmp/testfile_2"
destCath <- B.readFile (tmpFile cath "testfile_2")
destCath `shouldBe` src
where
cfg = testCfg {xftpDescrPartSize = 200}
@@ -6122,17 +6126,19 @@ testGroupHistoryLargeFile =
testGroupHistoryMultipleFiles :: HasCallStack => TestParams -> IO ()
testGroupHistoryMultipleFiles =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
\alice bob cath -> withXFTPServer alice $ do
let testfileBob = tmpFile bob "testfile_bob"
testfileAlice = tmpFile alice "testfile_alice"
xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob]
xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice]
createGroup2 "team" alice bob
threadDelay 1000000
bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]"
bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfileBob <> "\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]")
bob <# "#team hi alice"
bob <# "/f #team ./tests/tmp/testfile_bob"
bob <# ("/f #team " <> testfileBob)
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
@@ -6142,9 +6148,9 @@ testGroupHistoryMultipleFiles =
threadDelay 1000000
alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]"
alice ##> ("/_send #1 json [{\"filePath\": \"" <> testfileAlice <> "\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]")
alice <# "#team hey bob"
alice <# "/f #team ./tests/tmp/testfile_alice"
alice <# ("/f #team " <> testfileAlice)
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
@@ -6172,45 +6178,47 @@ testGroupHistoryMultipleFiles =
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir cath)
cath
<### [ "saving file 1 from bob to ./tests/tmp/testfile_bob_1",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile cath "testfile_bob_1",
"started receiving file 1 (testfile_bob) from bob"
]
cath <## "completed receiving file 1 (testfile_bob) from bob"
srcBob <- B.readFile "./tests/tmp/testfile_bob"
destBob <- B.readFile "./tests/tmp/testfile_bob_1"
srcBob <- B.readFile testfileBob
destBob <- B.readFile (tmpFile cath "testfile_bob_1")
destBob `shouldBe` srcBob
cath ##> "/fr 2 ./tests/tmp"
cath ##> ("/fr 2 " <> tmpDir cath)
cath
<### [ "saving file 2 from alice to ./tests/tmp/testfile_alice_1",
<### [ ConsoleString $ "saving file 2 from alice to " <> tmpFile cath "testfile_alice_1",
"started receiving file 2 (testfile_alice) from alice"
]
cath <## "completed receiving file 2 (testfile_alice) from alice"
srcAlice <- B.readFile "./tests/tmp/testfile_alice"
destAlice <- B.readFile "./tests/tmp/testfile_alice_1"
srcAlice <- B.readFile testfileAlice
destAlice <- B.readFile (tmpFile cath "testfile_alice_1")
destAlice `shouldBe` srcAlice
cath ##> "/_get chat #1 count=100"
r <- chatF <$> getTermLine cath
r
`shouldContain` [ ((0, "hi alice"), Just "./tests/tmp/testfile_bob_1"),
((0, "hey bob"), Just "./tests/tmp/testfile_alice_1")
`shouldContain` [ ((0, "hi alice"), Just $ tmpFile cath "testfile_bob_1"),
((0, "hey bob"), Just $ tmpFile cath "testfile_alice_1")
]
testGroupHistoryFileCancel :: HasCallStack => TestParams -> IO ()
testGroupHistoryFileCancel =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
\alice bob cath -> withXFTPServer alice $ do
let testfileBob = tmpFile bob "testfile_bob"
testfileAlice = tmpFile alice "testfile_alice"
xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob]
xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice]
createGroup2 "team" alice bob
bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]"
bob ##> ("/_send #1 json [{\"filePath\": \"" <> testfileBob <> "\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]")
bob <# "#team hi alice"
bob <# "/f #team ./tests/tmp/testfile_bob"
bob <# ("/f #team " <> testfileBob)
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
@@ -6224,9 +6232,9 @@ testGroupHistoryFileCancel =
threadDelay 1000000
alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]"
alice ##> ("/_send #1 json [{\"filePath\": \"" <> testfileAlice <> "\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]")
alice <# "#team hey bob"
alice <# "/f #team ./tests/tmp/testfile_alice"
alice <# ("/f #team " <> testfileAlice)
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
@@ -6257,9 +6265,11 @@ testGroupHistoryFileCancel =
testGroupHistoryFileCancelNoText :: HasCallStack => TestParams -> IO ()
testGroupHistoryFileCancelNoText =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile_bob", "2mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_bob"]
xftpCLI ["rand", "./tests/tmp/testfile_alice", "1mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile_alice"]
\alice bob cath -> withXFTPServer alice $ do
let testfileBob = tmpFile bob "testfile_bob"
testfileAlice = tmpFile alice "testfile_alice"
xftpCLI ["rand", testfileBob, "2mb"] `shouldReturn` ["File created: " <> testfileBob]
xftpCLI ["rand", testfileAlice, "1mb"] `shouldReturn` ["File created: " <> testfileAlice]
createGroup2 "team" alice bob
@@ -6268,7 +6278,7 @@ testGroupHistoryFileCancelNoText =
-- bob file
bob #> "/f #team ./tests/tmp/testfile_bob"
bob #> ("/f #team " <> testfileBob)
bob <## "use /fc 1 to cancel sending"
bob <## "completed uploading file 1 (testfile_bob) for #team"
@@ -6281,7 +6291,7 @@ testGroupHistoryFileCancelNoText =
-- alice file
alice #> "/f #team ./tests/tmp/testfile_alice"
alice #> ("/f #team " <> testfileAlice)
alice <## "use /fc 2 to cancel sending"
alice <## "completed uploading file 2 (testfile_alice) for #team"
@@ -7641,8 +7651,8 @@ testGroupMemberInactive ps = do
alice <# "#team bob> hey"
where
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
msgQueueQuota = 2
}
fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} -- same as in agent tests
@@ -8295,7 +8305,7 @@ testScopedSupportDontForwardBetweenScopes =
testScopedSupportForwardFile :: HasCallStack => TestParams -> IO ()
testScopedSupportForwardFile =
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> withXFTPServer $ do
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> withXFTPServer alice $ do
createGroup4 "team" alice (bob, GRMember) (cath, GRMember) (dan, GRModerator)
setupGroupForwarding alice bob dan
@@ -8318,9 +8328,9 @@ testScopedSupportForwardFile =
bob <## "completed uploading file 1 (test.jpg) for #team"
dan ##> "/fr 1 ./tests/tmp"
dan ##> ("/fr 1 " <> tmpDir dan)
dan
<### [ "saving file 1 from bob to ./tests/tmp/test.jpg",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile dan "test.jpg",
"started receiving file 1 (test.jpg) from bob"
]
dan <## "completed receiving file 1 (test.jpg) from bob"
@@ -11949,7 +11959,7 @@ testChannelMessageFile ps =
withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan ->
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do
createChannel1Relay "team" alice bob cath dan eve
-- the roster arrives as a file before this one; Postgres assigns it a new id and does not
-- reuse it on delete (SQLite does), so the received message file is id 2 here, 1 on SQLite.
@@ -11986,7 +11996,7 @@ testChannelMessageFile ps =
]
where
receiveFile cc name fileId src = do
let path = "./tests/tmp/test_" <> name <> ".jpg"
let path = tmpFile cc $ "test_" <> name <> ".jpg"
cc ##> ("/fr " <> show fileId <> " " <> path)
cc
<### [ ConsoleString ("saving file " <> show fileId <> " from #team to " <> path),
@@ -12001,7 +12011,7 @@ testChannelMessageFileCancel ps =
withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan ->
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do
createChannel1Relay "team" alice bob cath dan eve
#if defined(dbPostgres)
let rcvFileId = 2 :: Int
@@ -12181,7 +12191,7 @@ testChannelOwnerFileTransferAsMember ps =
withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan ->
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do
createChannel1Relay "team" alice bob cath dan eve
#if defined(dbPostgres)
let rcvFileId = 2 :: Int
@@ -12217,7 +12227,7 @@ testChannelOwnerFileTransferAsMember ps =
]
where
receiveFile cc name fileId src = do
let path = "./tests/tmp/test_" <> name <> ".jpg"
let path = tmpFile cc $ "test_" <> name <> ".jpg"
cc ##> ("/fr " <> show fileId <> " " <> path)
cc
<### [ ConsoleString ("saving file " <> show fileId <> " from alice to " <> path),
@@ -12232,7 +12242,7 @@ testGroupHistoryFileBadgeProof ps = do
let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, fileSizeLimits = FileSizeLimits {noBadge = 100000, supporter = 300000, legend = 400000}}
testChatCfg3 cfg aliceProfile bobProfile cathProfile (test sk) ps
where
test sk alice bob cath = withXFTPServer $ do
test sk alice bob cath = withXFTPServer ps $ do
createGroup2 "team" alice bob
addTestBadge alice =<< issueTestBadge sk futureDate
@@ -12261,14 +12271,14 @@ testGroupHistoryFileBadgeProof ps = do
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir ps)
cath
<### [ "saving file 1 from alice to ./tests/tmp/test.pdf",
<### [ ConsoleString $ "saving file 1 from alice to " <> tmpFile ps "test.pdf",
"started receiving file 1 (test.pdf) from alice"
]
cath <## "completed receiving file 1 (test.pdf) from alice"
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest <- B.readFile (tmpFile ps "test.pdf")
dest `shouldBe` src
testGroupHistoryRcvFileBadgeProof :: HasCallStack => TestParams -> IO ()
@@ -12277,7 +12287,7 @@ testGroupHistoryRcvFileBadgeProof ps = do
let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, fileSizeLimits = FileSizeLimits {noBadge = 100000, supporter = 300000, legend = 400000}}
testChatCfg3 cfg aliceProfile bobProfile cathProfile (test sk) ps
where
test sk alice bob cath = withXFTPServer $ do
test sk alice bob cath = withXFTPServer ps $ do
createGroup2 "team" alice bob
addTestBadge bob =<< issueTestBadge sk futureDate
@@ -12285,11 +12295,11 @@ testGroupHistoryRcvFileBadgeProof ps = do
bob <## "use /fc 1 to cancel sending"
alice <# "#team bob> sends file test.pdf (266.0 KiB / 272376 bytes)"
alice <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice ##> "/fr 1 ./tests/tmp"
alice ##> ("/fr 1 " <> tmpDir ps)
concurrentlyN_
[ bob <## "completed uploading file 1 (test.pdf) for #team",
alice
<### [ "saving file 1 from bob to ./tests/tmp/test.pdf",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile ps "test.pdf",
"started receiving file 1 (test.pdf) from bob"
]
]
@@ -12314,14 +12324,14 @@ testGroupHistoryRcvFileBadgeProof ps = do
bob <## "#team: new member cath is connected"
]
cath ##> "/fr 1 ./tests/tmp"
cath ##> ("/fr 1 " <> tmpDir ps)
cath
<### [ "saving file 1 from bob to ./tests/tmp/test_1.pdf",
<### [ ConsoleString $ "saving file 1 from bob to " <> tmpFile ps "test_1.pdf",
"started receiving file 1 (test.pdf) from bob"
]
cath <## "completed receiving file 1 (test.pdf) from bob"
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test_1.pdf"
dest <- B.readFile (tmpFile ps "test_1.pdf")
dest `shouldBe` src
testChannelFileBadgeProof :: HasCallStack => TestParams -> IO ()
@@ -12332,7 +12342,7 @@ testChannelFileBadgeProof ps = do
withNewTestChatCfgOpts ps cfg relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChatCfg ps cfg "cath" cathProfile $ \cath ->
withNewTestChatCfg ps cfg "dan" danProfile $ \dan ->
withNewTestChatCfg ps cfg "eve" eveProfile $ \eve -> withXFTPServer $ do
withNewTestChatCfg ps cfg "eve" eveProfile $ \eve -> withXFTPServer ps $ do
createChannel1Relay "team" alice bob cath dan eve
addTestBadge alice =<< issueTestBadge sk futureDate
#if defined(dbPostgres)
@@ -12359,7 +12369,7 @@ testChannelFileBadgeProof ps = do
]
src <- B.readFile "./tests/fixtures/test.jpg"
let path = "./tests/tmp/test_cath.jpg"
let path = tmpFile ps "test_cath.jpg"
cath ##> ("/fr " <> show rcvFileId <> " " <> path)
cath
<### [ ConsoleString ("saving file " <> show rcvFileId <> " from alice to " <> path),
@@ -12385,7 +12395,7 @@ testChannelFileBadgeProof ps = do
eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
eve <## ("use /fr " <> show (rcvFileId + 1) <> " [<dir>/ | <path>] to receive it [>>]")
]
let path2 = "./tests/tmp/test_cath_2.jpg"
let path2 = tmpFile ps "test_cath_2.jpg"
cath ##> ("/fr " <> show (rcvFileId + 1) <> " " <> path2)
cath
<### [ ConsoleString ("saving file " <> show (rcvFileId + 1) <> " from #team to " <> path2),
@@ -12400,7 +12410,7 @@ testChannelOwnerFileCancelAsMember ps =
withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan ->
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do
createChannel1Relay "team" alice bob cath dan eve
#if defined(dbPostgres)
let rcvFileId = 2 :: Int
@@ -12744,8 +12754,9 @@ testChannelSignedFile ps =
withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan ->
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do
xftpCLI ["rand", "./tests/tmp/testfile", "1mb"] `shouldReturn` ["File created: ./tests/tmp/testfile"]
withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer ps $ do
let testfile = tmpFile ps "testfile"
xftpCLI ["rand", testfile, "1mb"] `shouldReturn` ["File created: " <> testfile]
createChannel1Relay "team" alice bob cath dan eve
promoteChannelMember "team" alice bob cath [dan, eve]
-- roster serves arrive as files that Postgres deletes without reusing the id (SQLite reuses
@@ -12775,9 +12786,9 @@ testChannelSignedFile ps =
]
-- cath sends a signed file
cath ##> "/_send #1 sign=on json [{\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"signed file\",\"type\":\"file\"}}]"
cath ##> ("/_send #1 sign=on json [{\"filePath\": \"" <> testfile <> "\", \"msgContent\": {\"text\":\"signed file\",\"type\":\"file\"}}]")
cath <# "#team signed file (signed)"
cath <# "/f #team ./tests/tmp/testfile"
cath <# ("/f #team " <> testfile)
cath <## ("use /fc " <> show fileId <> " to cancel sending")
cath <## ("completed uploading file " <> show fileId <> " (testfile) for #team")
@@ -12798,14 +12809,14 @@ testChannelSignedFile ps =
]
-- dan downloads: the signed digest is verified and the file completes
dan ##> ("/fr " <> show fileId <> " ./tests/tmp")
dan ##> ("/fr " <> show fileId <> " " <> tmpDir ps)
dan
<### [ ConsoleString ("saving file " <> show fileId <> " from cath to ./tests/tmp/testfile_1"),
<### [ ConsoleString ("saving file " <> show fileId <> " from cath to " <> tmpFile ps "testfile_1"),
ConsoleString ("started receiving file " <> show fileId <> " (testfile) from cath")
]
dan <## ("completed receiving file " <> show fileId <> " (testfile) from cath")
src <- B.readFile "./tests/tmp/testfile"
destDan <- B.readFile "./tests/tmp/testfile_1"
src <- B.readFile testfile
destDan <- B.readFile (tmpFile ps "testfile_1")
destDan `shouldBe` src
-- the signed digest was carried to dan and stored, so verification ran (not skipped) and passed
digestCount <- withCCTransaction dan $ \db ->
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
@@ -28,7 +28,7 @@ chatNamesTests = do
it "connect by name resolving to business (primary) and channel" testConnectByNameBusinessAndChannel
testConnectByName :: HasCallStack => TestParams -> IO ()
testConnectByName ps = withSmpServerAndNames $ \reg ->
testConnectByName ps = withSmpServerAndNames ps $ \reg ->
testChat2 aliceProfile bobProfile (test reg) ps
where
aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -63,7 +63,7 @@ testConnectByName ps = withSmpServerAndNames $ \reg ->
pure ()
testConnectByNameNotClaimed :: HasCallStack => TestParams -> IO ()
testConnectByNameNotClaimed ps = withSmpServerAndNames $ \reg ->
testConnectByNameNotClaimed ps = withSmpServerAndNames ps $ \reg ->
testChat2 aliceProfile bobProfile (test reg) ps
where
aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -76,7 +76,7 @@ testConnectByNameNotClaimed ps = withSmpServerAndNames $ \reg ->
bob <## "SimpleX name alice.simplex is not included in the connection link's profile"
testConnectByNameKnownContactNotClaimed :: HasCallStack => TestParams -> IO ()
testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames $ \reg ->
testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames ps $ \reg ->
testChat2 aliceProfile bobProfile (test reg) ps
where
aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -99,7 +99,7 @@ testConnectByNameKnownContactNotClaimed ps = withSmpServerAndNames $ \reg ->
bob <## "SimpleX name alice.simplex is not included in the connection link's profile"
testConnectByNameNotFound :: HasCallStack => TestParams -> IO ()
testConnectByNameNotFound ps = withSmpServerAndNames $ \_reg ->
testConnectByNameNotFound ps = withSmpServerAndNames ps $ \_reg ->
testChat2 aliceProfile bobProfile test ps
where
test _alice bob = do
@@ -108,7 +108,7 @@ testConnectByNameNotFound ps = withSmpServerAndNames $ \_reg ->
bob .<## "smpErr = NAME {nameErr = NOT_FOUND}}"
testSetNameNotOwnAddress :: HasCallStack => TestParams -> IO ()
testSetNameNotOwnAddress ps = withSmpServerAndNames $ \reg ->
testSetNameNotOwnAddress ps = withSmpServerAndNames ps $ \reg ->
testChat2 aliceProfile bobProfile (test reg) ps
where
aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -124,7 +124,7 @@ testSetNameNotOwnAddress ps = withSmpServerAndNames $ \reg ->
-- a self-claimed name is never auto-verified from link data: the claim is not proof of ownership
testChannelDomainLinkJoinUnverified :: HasCallStack => TestParams -> IO ()
testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames $ \reg ->
testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
@@ -144,7 +144,7 @@ testChannelDomainLinkJoinUnverified ps = withSmpServerAndNames $ \reg ->
teamName = SimplexNameInfo NTPublicGroup (SimplexDomain TLDSimplex "team" [])
testChannelDomainVerify :: HasCallStack => TestParams -> IO ()
testChannelDomainVerify ps = withSmpServerAndNames $ \reg ->
testChannelDomainVerify ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
@@ -174,7 +174,7 @@ testChannelDomainVerify ps = withSmpServerAndNames $ \reg ->
teamName = SimplexNameInfo NTPublicGroup (SimplexDomain TLDSimplex "team" [])
testConnectByChannelName :: HasCallStack => TestParams -> IO ()
testConnectByChannelName ps = withSmpServerAndNames $ \reg ->
testConnectByChannelName ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
@@ -208,7 +208,7 @@ testConnectByChannelName ps = withSmpServerAndNames $ \reg ->
-- first and succeeds (bob has joined #team), so it is the primary (planSimplexName); otherSimplexName
-- is the direct contact @team.simplex, shown as "You can also connect to @team.simplex in direct chat".
testConnectByNameChannelAndContact :: HasCallStack => TestParams -> IO ()
testConnectByNameChannelAndContact ps = withSmpServerAndNames $ \reg ->
testConnectByNameChannelAndContact ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
@@ -247,7 +247,7 @@ testConnectByNameChannelAndContact ps = withSmpServerAndNames $ \reg ->
-- channel #acme, shown as "You can also join channel #acme". The channel link is a real, fetchable
-- #acme channel, so the failure is the faithful "channel does not claim this domain" case, not a broken link.
testConnectByNameContactAndChannel :: HasCallStack => TestParams -> IO ()
testConnectByNameContactAndChannel ps = withSmpServerAndNames $ \reg ->
testConnectByNameContactAndChannel ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
@@ -266,7 +266,7 @@ testConnectByNameContactAndChannel ps = withSmpServerAndNames $ \reg ->
acmeName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "acme" [])
testConnectByNameBusinessAndChannel :: HasCallStack => TestParams -> IO ()
testConnectByNameBusinessAndChannel ps = withSmpServerAndNames $ \reg ->
testConnectByNameBusinessAndChannel ps = withSmpServerAndNames ps $ \reg ->
withNewTestChat ps "alice" aliceProfile $ \alice ->
withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
tests/ChatTests/Profiles.hs
+39 -38
View File
@@ -737,26 +737,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 ()
@@ -800,8 +800,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
}
@@ -2467,12 +2467,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
@@ -2494,9 +2494,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
}
@@ -2534,13 +2535,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:"
@@ -3010,13 +3011,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"
@@ -3045,7 +3046,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"
@@ -3421,8 +3422,8 @@ testShortLinkInvitationConnectRetry ps = testChatOpts2 opts' aliceProfile bobPro
bob <## "disconnected 1 connections on server localhost"
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -3594,8 +3595,8 @@ testShortLinkAddressConnectRetry ps =
where
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -3657,8 +3658,8 @@ testShortLinkAddressConnectRetryIncognito ps =
where
tmp = tmpPath ps
serverCfg' =
smpServerCfg
{ transports = [("7003", transport @TLS, False)],
(smpServerCfg ps)
{ transports = [(smpTestPort2 ps, transport @TLS, False)],
serverStoreCfg = persistentServerStoreCfg tmp
}
opts' =
@@ -3939,8 +3940,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' =
tests/ChatTests/Utils.hs
+6 -5
View File
@@ -34,7 +34,6 @@ 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.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow, withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -43,9 +42,9 @@ 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 (getExecutablePath, lookupEnv)
import System.Info (os)
import System.Process (readProcess)
import Test.Hspec hiding (it)
import qualified Test.Hspec as Hspec
import UnliftIO (timeout)
@@ -745,7 +744,7 @@ connectUsers_ cc1 cc2 noShortLink = do
(cc1 <## (name2 <> ": contact is connected"))
showName :: TestCC -> IO String
showName (TestCC ChatController {currentUser} _ _ _ _ _) = do
showName TestCC {chatController = ChatController {currentUser}} = do
Just User {localDisplayName, profile = LocalProfile {fullName, shortDescr}} <- readTVarIO currentUser
pure . T.unpack $ viewName localDisplayName <> optionalFullName localDisplayName fullName shortDescr
@@ -890,7 +889,9 @@ 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 params = do
exe <- getExecutablePath
lines <$> readProcess exe ("xftp-cli" : params) ""
setRelativePaths :: HasCallStack => TestCC -> String -> String -> IO ()
setRelativePaths cc filesFolder tempFolder = do
tests/RemoteTests.hs
+13 -13
View File
@@ -190,8 +190,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
@@ -244,17 +244,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"
@@ -286,7 +286,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"
@@ -384,13 +384,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"
@@ -440,7 +440,7 @@ 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 <## ("saving file 2 from alice to " <> bobFiles <> "test.jpg")
bob <## "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
+35 -21
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
@@ -21,16 +22,17 @@ import ProtocolTests
import OperatorTests
import RandomServers
import RemoteTests
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
import System.Environment (getArgs, withArgs)
import Test.Hspec hiding (it)
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
@@ -40,25 +42,32 @@ import WebRTCTests
#endif
main :: IO ()
main = do
main =
getArgs >>= \case
"xftp-cli" : params -> withArgs params xftpClientCLI
_ -> runTests
runTests :: IO ()
runTests = do
setLogLevel LogError
#if !defined(dbPostgres)
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
@@ -73,13 +82,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) $ xdescribe'' "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)
@@ -90,24 +99,29 @@ main = do
xdescribe'' "SimpleX Directory service bot" directoryServiceTests
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}