mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 20:08:34 +00:00
769 lines
32 KiB
Haskell
769 lines
32 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module ChatClient where
|
|
|
|
import ChatTests.DBUtils
|
|
import Control.Concurrent (forkIOWithUnmask, killThread, threadDelay)
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (bracket, bracket_)
|
|
import Control.Logger.Simple (LogLevel (..))
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import Data.Functor (($>))
|
|
import Data.List (dropWhileEnd, find)
|
|
import qualified Data.List.NonEmpty as L
|
|
import Data.Maybe (isNothing)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Network.Socket
|
|
import Simplex.Chat
|
|
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), ChatResponse (..), WebPreviewConfig (..), defaultSimpleNetCfg)
|
|
import Simplex.Chat.Core
|
|
import Simplex.Chat.Library.Commands
|
|
import Simplex.Chat.Operators
|
|
import Simplex.Chat.Options
|
|
import Simplex.Chat.Options.DB
|
|
import Simplex.Chat.Store
|
|
import Simplex.Chat.Store.Profiles
|
|
import Simplex.Chat.Terminal
|
|
import Simplex.Chat.Terminal.Output (WithTerminal (..), newChatTerminal)
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Shared (GroupMemberRole (..))
|
|
import Simplex.FileTransfer.Description (kb, mb)
|
|
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
|
|
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), defaultFileExpiration)
|
|
import Simplex.FileTransfer.Server.Store
|
|
import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
|
|
import Simplex.Messaging.Agent (disposeAgentClient)
|
|
import Simplex.Messaging.Agent.Env.SQLite
|
|
import Simplex.Messaging.Agent.Protocol (supportedSMPAgentVRange)
|
|
import Simplex.Messaging.Agent.RetryInterval
|
|
import Simplex.Messaging.Agent.Store.Entity (SDBStored (..))
|
|
import Simplex.Messaging.Agent.Store.Interface (closeDBStore)
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError)
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Client (ProtocolClientConfig (..))
|
|
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
|
|
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)
|
|
import Simplex.Messaging.Server.MsgStore.STM (STMMsgStore)
|
|
import Simplex.Messaging.Transport
|
|
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
|
|
import Simplex.Messaging.Version
|
|
import Simplex.Messaging.Version.Internal
|
|
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
|
import System.FilePath ((</>))
|
|
import qualified System.Terminal as C
|
|
import System.Terminal.Internal (Command (..), Terminal (..), VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal)
|
|
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
|
|
import Simplex.Messaging.Agent.Client (agentClientStore)
|
|
import Simplex.Messaging.Agent.Store.Common (withConnection)
|
|
#endif
|
|
|
|
#if defined(dbPostgres)
|
|
schemaDumpDBOpts :: DBOpts
|
|
schemaDumpDBOpts =
|
|
DBOpts
|
|
{ connstr = B.pack testDBConnstr,
|
|
schema = "test_chat_schema",
|
|
poolSize = 10,
|
|
createSchema = True
|
|
}
|
|
|
|
testDBConnstr :: String
|
|
testDBConnstr = "postgresql://test_chat_user@/test_chat_db"
|
|
|
|
testDBConnectInfo :: ConnectInfo
|
|
testDBConnectInfo =
|
|
defaultConnectInfo {
|
|
connectUser = "test_chat_user",
|
|
connectDatabase = "test_chat_db"
|
|
}
|
|
#endif
|
|
|
|
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 =
|
|
ChatOpts
|
|
{ coreOptions = testCoreOpts,
|
|
chatCmd = "",
|
|
chatCmdDelay = 3,
|
|
chatCmdLog = CCLNone,
|
|
chatServerPort = Nothing,
|
|
optFilesFolder = Nothing,
|
|
optTempDirectory = Nothing,
|
|
showReactions = True,
|
|
showFullLinks = True,
|
|
allowInstantFiles = True,
|
|
autoAcceptFileSize = 0,
|
|
muteNotifications = True,
|
|
markRead = True,
|
|
createBot = Nothing,
|
|
userDisplayName = Nothing,
|
|
userImageFile = Nothing
|
|
}
|
|
|
|
testCoreOpts :: CoreChatOpts
|
|
testCoreOpts =
|
|
CoreChatOpts
|
|
{
|
|
dbOptions = ChatDbOpts
|
|
#if defined(dbPostgres)
|
|
{ dbConnstr = testDBConnstr,
|
|
-- dbSchemaPrefix is not used in tests (except bot tests where it's redefined),
|
|
-- instead different schema prefix is passed per client so that single test database is used
|
|
dbSchemaPrefix = "",
|
|
dbPoolSize = 10,
|
|
dbCreateSchema = True
|
|
#else
|
|
{ dbFilePrefix = "./simplex_v1", -- dbFilePrefix is not used in tests (except bot tests where it's redefined)
|
|
dbKey = "", -- dbKey = "this is a pass-phrase to encrypt the database",
|
|
trackQueries = DB.TQAll,
|
|
vacuumOnMigration = True
|
|
#endif
|
|
},
|
|
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
|
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
|
simpleNetCfg = defaultSimpleNetCfg,
|
|
logLevel = CLLImportant,
|
|
logConnections = False,
|
|
logServerHosts = False,
|
|
logAgent = Nothing,
|
|
logFile = Nothing,
|
|
tbqSize = 16,
|
|
maxChats = 5000,
|
|
deviceName = Nothing,
|
|
chatRelay = False,
|
|
webPreviewConfig = Nothing,
|
|
chatRelayServer = Nothing,
|
|
headless = False,
|
|
highlyAvailable = False,
|
|
yesToUpMigrations = False,
|
|
migrationBackupPath = Nothing,
|
|
maintenance = False
|
|
}
|
|
|
|
relayTestOpts :: ChatOpts
|
|
relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}}
|
|
|
|
testOptsNoFullLinks :: ChatOpts
|
|
testOptsNoFullLinks = testOpts {showFullLinks = False}
|
|
|
|
relayTestOptsNoFullLinks :: ChatOpts
|
|
relayTestOptsNoFullLinks = relayTestOpts {showFullLinks = False}
|
|
|
|
relayWebTestOpts :: Text -> FilePath -> Maybe FilePath -> ChatOpts
|
|
relayWebTestOpts webDomain webDir webCorsFile = testOpts {coreOptions = testCoreOpts {chatRelay = True, webPreviewConfig = Just WebPreviewConfig {webDomain, webJsonDir = webDir, webCorsFile, webUpdateInterval = 300, webPreviewItemCount = 50}}}
|
|
|
|
#if !defined(dbPostgres)
|
|
getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts
|
|
getTestOpts maintenance dbKey = testOpts {coreOptions = testCoreOpts {maintenance, dbOptions = (dbOptions testCoreOpts) {dbKey}}}
|
|
#endif
|
|
|
|
termSettings :: VirtualTerminalSettings
|
|
termSettings =
|
|
VirtualTerminalSettings
|
|
{ virtualType = "xterm",
|
|
virtualWindowSize = pure C.Size {height = 24, width = 7500},
|
|
virtualEvent = retry,
|
|
virtualInterrupt = retry
|
|
}
|
|
|
|
data TestCC = TestCC
|
|
{ chatController :: ChatController,
|
|
chatAsync :: Async (),
|
|
termQ :: TQueue String,
|
|
printOutput :: Bool,
|
|
ccParams :: TestParams
|
|
}
|
|
|
|
data TestTerminal = TestTerminal VirtualTerminal (TQueue String)
|
|
|
|
instance Terminal TestTerminal where
|
|
termType (TestTerminal t _) = termType t
|
|
termEvent (TestTerminal t _) = termEvent t
|
|
termInterrupt (TestTerminal t _) = termInterrupt t
|
|
termCommand (TestTerminal t q) c = do
|
|
case c of
|
|
PutLn -> atomically $ do
|
|
C.Position {row} <- readTVar $ virtualCursor t
|
|
rows <- readTVar $ virtualWindow t
|
|
writeTQueue q $ dropWhileEnd (== ' ') $ rows !! row
|
|
_ -> pure ()
|
|
termCommand t c
|
|
termFlush (TestTerminal t _) = termFlush t
|
|
termGetWindowSize (TestTerminal t _) = termGetWindowSize t
|
|
termGetCursorPosition (TestTerminal t _) = termGetCursorPosition t
|
|
|
|
instance WithTerminal TestTerminal where
|
|
withTerm t = ($ t)
|
|
|
|
aCfg :: AgentConfig
|
|
aCfg = (agentConfig defaultChatConfig) {tbqSize = 16}
|
|
|
|
testAgentCfg :: AgentConfig
|
|
testAgentCfg =
|
|
aCfg
|
|
{ reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000},
|
|
messageRetryInterval = RetryInterval2 {riFast = riFast {initialInterval = 50000}, riSlow = riSlow {initialInterval = 50000}}
|
|
}
|
|
where
|
|
RetryInterval2 {riFast, riSlow} = messageRetryInterval aCfg
|
|
|
|
testCfg :: ChatConfig
|
|
testCfg =
|
|
defaultChatConfig
|
|
{ agentConfig = testAgentCfg,
|
|
showReceipts = False,
|
|
shortLinkPresetServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"],
|
|
testView = True,
|
|
tbqSize = 16,
|
|
channelSubscriberRole = GRObserver,
|
|
confirmMigrations = MCYesUp
|
|
}
|
|
|
|
testAgentCfgVPrev :: AgentConfig
|
|
testAgentCfgVPrev =
|
|
testAgentCfg
|
|
{ smpClientVRange = prevRange $ smpClientVRange testAgentCfg,
|
|
smpAgentVRange = prevRange supportedSMPAgentVRange,
|
|
-- e2eEncryptVRange = prevRange supportedE2EEncryptVRange,
|
|
smpCfg = (smpCfg testAgentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg testAgentCfg}
|
|
}
|
|
|
|
testAgentCfgV1 :: AgentConfig
|
|
testAgentCfgV1 =
|
|
testAgentCfg
|
|
{ smpClientVRange = v1Range,
|
|
smpAgentVRange = versionToRange (Version 6),
|
|
e2eEncryptVRange = versionToRange(Version 3),
|
|
smpCfg = (smpCfg testAgentCfg) {serverVRange = versionToRange minClientSMPRelayVersion}
|
|
}
|
|
|
|
testCfgVPrev :: ChatConfig
|
|
testCfgVPrev =
|
|
testCfg
|
|
{ chatVRange = prevRange $ chatVRange testCfg,
|
|
agentConfig = testAgentCfgVPrev
|
|
}
|
|
|
|
testCfgV1 :: ChatConfig
|
|
testCfgV1 =
|
|
testCfg
|
|
{ chatVRange = chatInitialVRange,
|
|
agentConfig = testAgentCfgV1
|
|
}
|
|
|
|
prevRange :: VersionRange v -> VersionRange v
|
|
prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)}
|
|
|
|
nextRange :: VersionRange v -> VersionRange v
|
|
nextRange vr = vr {maxVersion = max (minVersion vr) (nextVersion $ maxVersion vr)}
|
|
|
|
v1Range :: VersionRange v
|
|
v1Range = mkVersionRange (Version 1) (Version 1)
|
|
|
|
prevVersion :: Version v -> Version v
|
|
prevVersion (Version v) = Version (v - 1)
|
|
|
|
nextVersion :: Version v -> Version v
|
|
nextVersion (Version v) = Version (v + 1)
|
|
|
|
createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> IO TestCC
|
|
createTestChat ps cfg opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {chatRelay}} dbPrefix clientService profile = do
|
|
Right db@ChatDatabase {chatStore, agentStore} <- createDatabase ps coreOptions dbPrefix
|
|
insertUser agentStore
|
|
ts <- getCurrentTime
|
|
Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecordAt db' (AgentUserId 1) chatRelay clientService profile True ts
|
|
startTestChat_ ps db cfg opts dbPrefix user
|
|
|
|
startTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> IO TestCC
|
|
startTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix = do
|
|
Right db@ChatDatabase {chatStore} <- createDatabase ps coreOptions dbPrefix
|
|
Just user <- find activeUser <$> withTransaction chatStore getUsers
|
|
startTestChat_ ps db cfg opts dbPrefix user
|
|
|
|
createDatabase :: TestParams -> CoreChatOpts -> String -> IO (Either MigrationError ChatDatabase)
|
|
#if defined(dbPostgres)
|
|
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")
|
|
#else
|
|
createDatabase TestParams {tmpPath} CoreChatOpts {dbOptions} dbPrefix = do
|
|
createChatDatabase dbOptions {dbFilePrefix = tmpPath </> dbPrefix} (MigrationConfig MCError Nothing)
|
|
|
|
insertUser :: DBStore -> IO ()
|
|
insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")
|
|
#endif
|
|
|
|
startTestChat_ :: TestParams -> ChatDatabase -> ChatConfig -> ChatOpts -> String -> User -> IO TestCC
|
|
startTestChat_ ps@TestParams {tmpPath, printOutput} db cfg_ opts_ dbPrefix user = do
|
|
let (cfg, opts@ChatOpts {coreOptions = CoreChatOpts {maintenance}}) = testPortsCfg ps cfg_ opts_
|
|
termQ <- newTQueueIO
|
|
t <- withVirtualTerminal termSettings $ pure . (`TestTerminal` termQ)
|
|
ct <- newChatTerminal t opts
|
|
Right cc <- newChatController db (Just user) cfg opts False
|
|
void $ execChatCommand' (SetTempFolder (tmpPath </> dbPrefix)) 0 `runReaderT` cc
|
|
chatAsync <- async $ runSimplexChat cfg opts user cc $ \_u cc' -> runChatTerminal ct cc' opts
|
|
unless maintenance $ atomically $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
|
|
pure TestCC {chatController = cc, chatAsync, termQ, printOutput, ccParams = ps}
|
|
|
|
stopTestChat :: TestParams -> TestCC -> IO ()
|
|
stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}, chatAsync} = do
|
|
stopped <- async $ do
|
|
stopChatController cc
|
|
cancel chatAsync
|
|
disposeAgentClient smpAgent
|
|
r <- timeout 60000000 $ wait stopped
|
|
#if !defined(dbPostgres)
|
|
chatStats <- withConnection chatStore $ readTVarIO . DB.slow
|
|
atomically $ modifyTVar' (chatQueryStats ps) $ M.unionWith combineStats chatStats
|
|
agentStats <- withConnection (agentClientStore smpAgent) $ readTVarIO . DB.slow
|
|
atomically $ modifyTVar' (agentQueryStats ps) $ M.unionWith combineStats agentStats
|
|
#endif
|
|
case r of
|
|
Just () -> closeDBStore chatStore
|
|
Nothing -> putStrLn "stopTestChat: chat did not stop in 60 seconds"
|
|
threadDelay 200000
|
|
#if !defined(dbPostgres)
|
|
where
|
|
combineStats
|
|
DB.SlowQueryStats {count, timeMax, timeAvg, errs}
|
|
DB.SlowQueryStats {count = count', timeMax = timeMax', timeAvg = timeAvg', errs = errs'} =
|
|
DB.SlowQueryStats
|
|
{ count = count + count',
|
|
timeMax = max timeMax timeMax',
|
|
timeAvg = (timeAvg * count + timeAvg' * count') `div` (count + count'),
|
|
errs = M.unionWith (+) errs errs'
|
|
}
|
|
#endif
|
|
|
|
withNewTestChat :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChat ps = withNewTestChatCfgOpts ps testCfg testOpts
|
|
|
|
withNewTestChat_ :: HasCallStack => TestParams -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChat_ ps = withNewTestChatCfgOpts_ ps testCfg testOpts
|
|
|
|
withNewTestChatV1 :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatV1 ps = withNewTestChatCfg ps testCfgV1
|
|
|
|
withNewTestChatCfg :: HasCallStack => TestParams -> ChatConfig -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatCfg ps cfg = withNewTestChatCfgOpts ps cfg testOpts
|
|
|
|
withNewTestChatOpts :: HasCallStack => TestParams -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatOpts ps = withNewTestChatCfgOpts ps testCfg
|
|
|
|
withNewTestChatCfgOpts :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatCfgOpts ps cfg opts dbPrefix = withNewTestChatCfgOpts_ ps cfg opts dbPrefix False
|
|
|
|
withNewTestChatCfgOpts_ :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatCfgOpts_ ps cfg opts dbPrefix clientService profile runTest =
|
|
bracket
|
|
(createTestChat ps cfg opts dbPrefix clientService profile)
|
|
(stopTestChat ps)
|
|
(\cc -> runTest cc >>= ((cc <// 100000) $>))
|
|
|
|
withTestChatV1 :: HasCallStack => TestParams -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatV1 ps = withTestChatCfg ps testCfgV1
|
|
|
|
withTestChat :: HasCallStack => TestParams -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChat ps = withTestChatCfgOpts ps testCfg testOpts
|
|
|
|
withTestChatCfg :: HasCallStack => TestParams -> ChatConfig -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatCfg ps cfg = withTestChatCfgOpts ps cfg testOpts
|
|
|
|
withTestChatOpts :: HasCallStack => TestParams -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatOpts ps = withTestChatCfgOpts ps testCfg
|
|
|
|
withTestChatCfgOpts :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatCfgOpts ps cfg opts dbPrefix runTest =
|
|
bracket (startTestChat ps cfg opts dbPrefix) (stopTestChat ps) (\cc -> runTest cc >>= ((cc <// 100000) $>))
|
|
|
|
-- enable output for specific test.
|
|
-- usage: withTestOutput $ testChat2 aliceProfile bobProfile $ \alice bob -> do ...
|
|
withTestOutput :: HasCallStack => (HasCallStack => TestParams -> IO ()) -> TestParams -> IO ()
|
|
withTestOutput test ps = test ps {printOutput = True}
|
|
|
|
-- Opt the client's SMP servers into name resolution (self-hosted servers default names off).
|
|
enableNamesRole :: HasCallStack => TestCC -> IO ()
|
|
enableNamesRole TestCC {chatController = cc} = do
|
|
r <- execChatCommand' (APIGetUserServers 1) 0 `runReaderT` cc
|
|
case r of
|
|
Right (CRUserServers _ uoss) -> do
|
|
r' <- execChatCommand' (APISetUserServers 1 (L.fromList (map toUpdated uoss))) 0 `runReaderT` cc
|
|
either (fail . show) (const $ pure ()) r'
|
|
Right other -> fail $ "enableNamesRole: unexpected response " <> show other
|
|
Left e -> fail $ "enableNamesRole: APIGetUserServers failed " <> show e
|
|
where
|
|
toUpdated UserOperatorServers {operator, smpServers, xftpServers, chatRelays} =
|
|
UpdatedUserOperatorServers
|
|
{ operator,
|
|
smpServers = map (AUS SDBStored . enableNames) smpServers,
|
|
xftpServers = map (AUS SDBStored) xftpServers,
|
|
chatRelays = map (AUCR SDBStored) chatRelays
|
|
}
|
|
enableNames srv@UserServer {roles} = (srv :: UserServer 'PSMP) {roles = (roles :: ServerRolesOverride) {names = Just True}}
|
|
|
|
withTmpFiles :: IO () -> IO ()
|
|
withTmpFiles =
|
|
bracket_
|
|
(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 ..]) (mapConcurrently_ $ stopTestChat params) $ \tcs -> do
|
|
test tcs
|
|
mapConcurrently_ (<// 100000) tcs
|
|
where
|
|
useClientServices = False
|
|
-- useClientServices = True
|
|
getTestCCs :: [(Profile, Int)] -> IO [TestCC]
|
|
getTestCCs [] = pure []
|
|
getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) useClientServices p <*> getTestCCs envs'
|
|
|
|
(<//) :: HasCallStack => TestCC -> Int -> Expectation
|
|
(<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing
|
|
|
|
getTermLine :: HasCallStack => TestCC -> IO String
|
|
getTermLine = getTermLine' Nothing
|
|
|
|
getTermLine' :: HasCallStack => Maybe String -> TestCC -> IO String
|
|
getTermLine' expected cc@TestCC {printOutput} =
|
|
20000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case
|
|
Just s -> do
|
|
-- remove condition to always echo virtual terminal
|
|
-- when True $ do
|
|
when printOutput $ do
|
|
name <- userName cc
|
|
putStrLn $ name <> ": " <> s
|
|
pure s
|
|
Nothing -> do
|
|
name <- userName cc
|
|
let expectedMsg = case expected of
|
|
Just e -> ", expected: " <> show e
|
|
Nothing -> ""
|
|
error $ name <> ": no output for 20 seconds" <> expectedMsg
|
|
|
|
userName :: TestCC -> IO [Char]
|
|
userName TestCC {chatController = ChatController {currentUser}} =
|
|
maybe "no current user" (\User {localDisplayName} -> T.unpack localDisplayName) <$> readTVarIO currentUser
|
|
|
|
testChat :: HasCallStack => Profile -> (HasCallStack => TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChat = testChatCfgOpts testCfg testOpts
|
|
|
|
testChatCfgOpts :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> (HasCallStack => TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfgOpts cfg opts p test = testChatN cfg opts [p] test_
|
|
where
|
|
test_ :: HasCallStack => [TestCC] -> IO ()
|
|
test_ [tc] = test tc
|
|
test_ _ = error "expected 1 chat client"
|
|
|
|
testChat2 :: HasCallStack => Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChat2 = testChatCfgOpts2 testCfg testOpts
|
|
|
|
testChatCfg2 :: HasCallStack => ChatConfig -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfg2 cfg = testChatCfgOpts2 cfg testOpts
|
|
|
|
testChatOpts2 :: HasCallStack => ChatOpts -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatOpts2 = testChatCfgOpts2 testCfg
|
|
|
|
testChatCfgOpts2 :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfgOpts2 cfg opts p1 p2 test = testChatN cfg opts [p1, p2] test_
|
|
where
|
|
test_ :: HasCallStack => [TestCC] -> IO ()
|
|
test_ [tc1, tc2] = test tc1 tc2
|
|
test_ _ = error "expected 2 chat clients"
|
|
|
|
testChat3 :: HasCallStack => Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChat3 = testChatCfgOpts3 testCfg testOpts
|
|
|
|
testChatCfg3 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfg3 cfg = testChatCfgOpts3 cfg testOpts
|
|
|
|
testChatOpts3 :: HasCallStack => ChatOpts -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatOpts3 = testChatCfgOpts3 testCfg
|
|
|
|
testChatCfgOpts3 :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfgOpts3 cfg opts p1 p2 p3 test = testChatN cfg opts [p1, p2, p3] test_
|
|
where
|
|
test_ :: HasCallStack => [TestCC] -> IO ()
|
|
test_ [tc1, tc2, tc3] = test tc1 tc2 tc3
|
|
test_ _ = error "expected 3 chat clients"
|
|
|
|
testChat4 :: HasCallStack => Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChat4 = testChatCfgOpts4 testCfg testOpts
|
|
|
|
testChatCfg4 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfg4 cfg = testChatCfgOpts4 cfg testOpts
|
|
|
|
testChatOpts4 :: HasCallStack => ChatOpts -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatOpts4 = testChatCfgOpts4 testCfg
|
|
|
|
testChatCfgOpts4 :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfgOpts4 cfg opts p1 p2 p3 p4 test = testChatN cfg opts [p1, p2, p3, p4] test_
|
|
where
|
|
test_ :: HasCallStack => [TestCC] -> IO ()
|
|
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4
|
|
test_ _ = error "expected 4 chat clients"
|
|
|
|
testChat5 :: HasCallStack => Profile -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChat5 = testChatCfg5 testCfg
|
|
|
|
testChatCfg5 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
|
|
testChatCfg5 cfg p1 p2 p3 p4 p5 test = testChatN cfg testOpts [p1, p2, p3, p4, p5] test_
|
|
where
|
|
test_ :: HasCallStack => [TestCC] -> IO ()
|
|
test_ [tc1, tc2, tc3, tc4, tc5] = test tc1 tc2 tc3 tc4 tc5
|
|
test_ _ = error "expected 5 chat clients"
|
|
|
|
concurrentlyN_ :: [IO a] -> IO ()
|
|
concurrentlyN_ = mapConcurrently_ id
|
|
|
|
smpServerCfg :: HasTestParams a => a -> ServerConfig STMMsgStore
|
|
smpServerCfg p =
|
|
ServerConfig
|
|
{ transports = [(smpTestPort p, transport @TLS, False)],
|
|
tbqSize = 4,
|
|
msgQueueQuota = 16,
|
|
maxJournalMsgCount = 24,
|
|
maxJournalStateLines = 4,
|
|
queueIdBytes = 24,
|
|
msgIdBytes = 6,
|
|
serverStoreCfg = SSCMemory Nothing, -- $ Just StorePaths {storeLogFile = "tmp/smp-server-store.log", storeMsgsFile = Just "tmp/smp-server-messages.log"},
|
|
storeNtfsFile = Nothing,
|
|
allowNewQueues = True,
|
|
-- server password is disabled as otherwise v1 tests fail
|
|
newQueueBasicAuth = Nothing, -- Just "server_password",
|
|
controlPortUserAuth = Nothing,
|
|
controlPortAdminAuth = Nothing,
|
|
dailyBlockQueueQuota = 20,
|
|
messageExpiration = Just defaultMessageExpiration,
|
|
expireMessagesOnStart = False,
|
|
expireMessagesOnSend = False,
|
|
idleQueueInterval = defaultIdleQueueInterval,
|
|
notificationExpiration = defaultNtfExpiration,
|
|
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
|
smpCredentials =
|
|
ServerCredentials
|
|
{ caCertificateFile = Just "tests/fixtures/tls/ca.crt",
|
|
privateKeyFile = "tests/fixtures/tls/server.key",
|
|
certificateFile = "tests/fixtures/tls/server.crt"
|
|
},
|
|
httpCredentials = Nothing,
|
|
logStatsInterval = Nothing,
|
|
logStatsStartTime = 0,
|
|
serverStatsLogFile = "tests/smp-server-stats.daily.log",
|
|
serverStatsBackupFile = Nothing,
|
|
prometheusInterval = Nothing,
|
|
prometheusMetricsFile = "tests/smp-server-metrics.txt",
|
|
pendingENDInterval = 500000,
|
|
ntfDeliveryInterval = 200000,
|
|
smpServerVRange = supportedServerSMPRelayVRange,
|
|
transportConfig = mkTransportServerConfig True (Just alpnSupportedSMPHandshakes) True,
|
|
smpHandshakeTimeout = 1000000,
|
|
controlPort = Nothing,
|
|
smpAgentCfg = defaultSMPClientAgentConfig,
|
|
allowSMPProxy = True,
|
|
serverClientConcurrency = 16,
|
|
serverResolverConcurrency = 1000,
|
|
namesConfig = Nothing,
|
|
information = Nothing,
|
|
startOptions = StartOptions {maintenance = False, compactLog = False, logLevel = LogError, skipWarnings = False, confirmMigrations = MCYesUp}
|
|
}
|
|
|
|
persistentServerStoreCfg :: FilePath -> ServerStoreCfg STMMsgStore
|
|
persistentServerStoreCfg tmp = SSCMemory $ Just StorePaths {storeLogFile = tmp <> "/smp-server-store.log", storeMsgsFile = Just $ tmp <> "/smp-server-messages.log"}
|
|
|
|
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 :: HasTestParams a => a -> (NameRegistry -> IO b) -> IO b
|
|
withSmpServerAndNames p action =
|
|
withNameResolver $ \port reg ->
|
|
withSmpServer' (smpServerCfg p) {namesConfig = Just (resolverNamesConfig port)} (action reg)
|
|
|
|
xftpServerFiles :: HasTestParams a => a -> FilePath
|
|
xftpServerFiles p = tmpFile p "xftp-server-files"
|
|
|
|
xftpServerConfig :: HasTestParams a => a -> XFTPServerConfig STMFileStore
|
|
xftpServerConfig p =
|
|
XFTPServerConfig
|
|
{ xftpPort = xftpTestPort p,
|
|
fileIdSize = 16,
|
|
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,
|
|
newFileBasicAuth = Nothing,
|
|
controlPortUserAuth = Nothing,
|
|
controlPortAdminAuth = Nothing,
|
|
fileExpiration = defaultFileExpiration,
|
|
fileStorageEntitlements = mempty,
|
|
entitlementKeys = mempty,
|
|
fileTimeout = 10000000,
|
|
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
|
xftpCredentials =
|
|
ServerCredentials
|
|
{ caCertificateFile = Just "tests/fixtures/tls/ca.crt",
|
|
privateKeyFile = "tests/fixtures/tls/server.key",
|
|
certificateFile = "tests/fixtures/tls/server.crt"
|
|
},
|
|
httpCredentials = Nothing,
|
|
webStaticPath = Nothing,
|
|
xftpServerVRange = supportedFileServerVRange,
|
|
information = Nothing,
|
|
logStatsInterval = Nothing,
|
|
logStatsStartTime = 0,
|
|
serverStatsLogFile = tmpFile p "xftp-server-stats.daily.log",
|
|
serverStatsBackupFile = Nothing,
|
|
prometheusInterval = Nothing,
|
|
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 :: HasTestParams a => a -> IO b -> IO b
|
|
withXFTPServer p = withXFTPServer' (xftpServerConfig p)
|
|
|
|
withXFTPServer' :: XFTPServerConfig STMFileStore -> IO a -> IO a
|
|
withXFTPServer' cfg@XFTPServerConfig {filesPath} =
|
|
serverBracket
|
|
( \started -> do
|
|
createDirectoryIfMissing False filesPath
|
|
runXFTPServerBlocking started cfg
|
|
)
|
|
|
|
serverBracket :: (TMVar Bool -> IO ()) -> IO a -> IO a
|
|
serverBracket server f = do
|
|
started <- newEmptyTMVarIO
|
|
bracket
|
|
(forkIOWithUnmask ($ server started))
|
|
(\t -> killThread t >> waitFor started "stop" >> threadDelay 100000)
|
|
(\_ -> waitFor started "start" >> f)
|
|
where
|
|
waitFor started s =
|
|
5000000 `timeout` atomically (takeTMVar started) >>= \case
|
|
Nothing -> error $ "server did not " <> s
|
|
_ -> pure ()
|