mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
410 lines
16 KiB
Haskell
410 lines
16 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module ChatClient where
|
|
|
|
import Control.Concurrent (forkIOWithUnmask, killThread, threadDelay)
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (bracket, bracket_)
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Data.Functor (($>))
|
|
import Data.List (dropWhileEnd, find)
|
|
import Data.Maybe (fromJust, isNothing)
|
|
import qualified Data.Text as T
|
|
import Network.Socket
|
|
import Simplex.Chat
|
|
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..))
|
|
import Simplex.Chat.Core
|
|
import Simplex.Chat.Options
|
|
import Simplex.Chat.Store
|
|
import Simplex.Chat.Store.Profiles
|
|
import Simplex.Chat.Terminal
|
|
import Simplex.Chat.Terminal.Output (newChatTerminal)
|
|
import Simplex.Chat.Types (AgentUserId (..), Profile, User (..))
|
|
import Simplex.FileTransfer.Description (kb, mb)
|
|
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
|
|
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
|
|
import Simplex.Messaging.Agent.Env.SQLite
|
|
import Simplex.Messaging.Agent.RetryInterval
|
|
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
|
|
import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultNetworkConfig)
|
|
import Simplex.Messaging.Server (runSMPServerBlocking)
|
|
import Simplex.Messaging.Server.Env.STM
|
|
import Simplex.Messaging.Transport
|
|
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig)
|
|
import Simplex.Messaging.Version
|
|
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
|
import System.FilePath ((</>))
|
|
import qualified System.Terminal as C
|
|
import System.Terminal.Internal (VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal)
|
|
import System.Timeout (timeout)
|
|
import Test.Hspec (Expectation, HasCallStack, shouldReturn)
|
|
|
|
testDBPrefix :: FilePath
|
|
testDBPrefix = "tests/tmp/test"
|
|
|
|
serverPort :: ServiceName
|
|
serverPort = "7001"
|
|
|
|
testOpts :: ChatOpts
|
|
testOpts =
|
|
ChatOpts
|
|
{ coreOptions =
|
|
CoreChatOpts
|
|
{ dbFilePrefix = undefined,
|
|
dbKey = "",
|
|
-- dbKey = "this is a pass-phrase to encrypt the database",
|
|
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
|
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
|
networkConfig = defaultNetworkConfig,
|
|
logLevel = CLLImportant,
|
|
logConnections = False,
|
|
logServerHosts = False,
|
|
logAgent = Nothing,
|
|
logFile = Nothing,
|
|
tbqSize = 16,
|
|
highlyAvailable = False
|
|
},
|
|
deviceName = Nothing,
|
|
chatCmd = "",
|
|
chatCmdDelay = 3,
|
|
chatServerPort = Nothing,
|
|
optFilesFolder = Nothing,
|
|
showReactions = True,
|
|
allowInstantFiles = True,
|
|
autoAcceptFileSize = 0,
|
|
muteNotifications = True,
|
|
maintenance = False
|
|
}
|
|
|
|
getTestOpts :: Bool -> String -> ChatOpts
|
|
getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = (coreOptions testOpts) {dbKey}}
|
|
|
|
termSettings :: VirtualTerminalSettings
|
|
termSettings =
|
|
VirtualTerminalSettings
|
|
{ virtualType = "xterm",
|
|
virtualWindowSize = pure C.Size {height = 24, width = 2250},
|
|
virtualEvent = retry,
|
|
virtualInterrupt = retry
|
|
}
|
|
|
|
data TestCC = TestCC
|
|
{ chatController :: ChatController,
|
|
virtualTerminal :: VirtualTerminal,
|
|
chatAsync :: Async (),
|
|
termAsync :: Async (),
|
|
termQ :: TQueue String,
|
|
printOutput :: Bool
|
|
}
|
|
|
|
aCfg :: AgentConfig
|
|
aCfg = (agentConfig defaultChatConfig) {tbqSize = 16}
|
|
|
|
testAgentCfg :: AgentConfig
|
|
testAgentCfg =
|
|
aCfg
|
|
{ reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000},
|
|
xftpNotifyErrsOnRetry = False
|
|
}
|
|
|
|
testCfg :: ChatConfig
|
|
testCfg =
|
|
defaultChatConfig
|
|
{ agentConfig = testAgentCfg,
|
|
showReceipts = False,
|
|
testView = True,
|
|
tbqSize = 16,
|
|
xftpFileConfig = Nothing
|
|
}
|
|
|
|
testAgentCfgV1 :: AgentConfig
|
|
testAgentCfgV1 =
|
|
testAgentCfg
|
|
{ smpClientVRange = mkVersionRange 1 1,
|
|
smpAgentVRange = mkVersionRange 1 1,
|
|
smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange 1 1}
|
|
}
|
|
|
|
testCfgV1 :: ChatConfig
|
|
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
|
|
|
|
testCfgCreateGroupDirect :: ChatConfig
|
|
testCfgCreateGroupDirect =
|
|
mkCfgCreateGroupDirect testCfg
|
|
|
|
mkCfgCreateGroupDirect :: ChatConfig -> ChatConfig
|
|
mkCfgCreateGroupDirect cfg = cfg {chatVRange = groupCreateDirectVRange}
|
|
|
|
groupCreateDirectVRange :: VersionRange
|
|
groupCreateDirectVRange = mkVersionRange 1 1
|
|
|
|
testCfgGroupLinkViaContact :: ChatConfig
|
|
testCfgGroupLinkViaContact =
|
|
mkCfgGroupLinkViaContact testCfg
|
|
|
|
mkCfgGroupLinkViaContact :: ChatConfig -> ChatConfig
|
|
mkCfgGroupLinkViaContact cfg = cfg {chatVRange = groupLinkViaContactVRange}
|
|
|
|
groupLinkViaContactVRange :: VersionRange
|
|
groupLinkViaContactVRange = mkVersionRange 1 2
|
|
|
|
createTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
|
|
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do
|
|
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError
|
|
Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile True
|
|
startTestChat_ db cfg opts user
|
|
|
|
startTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> IO TestCC
|
|
startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix = do
|
|
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey MCError
|
|
Just user <- find activeUser <$> withTransaction chatStore getUsers
|
|
startTestChat_ db cfg opts user
|
|
|
|
startTestChat_ :: ChatDatabase -> ChatConfig -> ChatOpts -> User -> IO TestCC
|
|
startTestChat_ db cfg opts user = do
|
|
t <- withVirtualTerminal termSettings pure
|
|
ct <- newChatTerminal t opts
|
|
cc <- newChatController db (Just user) cfg opts
|
|
chatAsync <- async . runSimplexChat opts user cc . const $ runChatTerminal ct
|
|
atomically . unless (maintenance opts) $ 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 = False}
|
|
|
|
stopTestChat :: TestCC -> IO ()
|
|
stopTestChat TestCC {chatController = cc, chatAsync, termAsync} = do
|
|
stopChatController cc
|
|
uninterruptibleCancel termAsync
|
|
uninterruptibleCancel chatAsync
|
|
threadDelay 200000
|
|
|
|
withNewTestChat :: HasCallStack => FilePath -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChat tmp = withNewTestChatCfgOpts tmp testCfg testOpts
|
|
|
|
withNewTestChatV1 :: HasCallStack => FilePath -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatV1 tmp = withNewTestChatCfg tmp testCfgV1
|
|
|
|
withNewTestChatCfg :: HasCallStack => FilePath -> ChatConfig -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatCfg tmp cfg = withNewTestChatCfgOpts tmp cfg testOpts
|
|
|
|
withNewTestChatOpts :: HasCallStack => FilePath -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatOpts tmp = withNewTestChatCfgOpts tmp testCfg
|
|
|
|
withNewTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withNewTestChatCfgOpts tmp cfg opts dbPrefix profile runTest =
|
|
bracket
|
|
(createTestChat tmp cfg opts dbPrefix profile)
|
|
stopTestChat
|
|
(\cc -> runTest cc >>= ((cc <// 100000) $>))
|
|
|
|
withTestChatV1 :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatV1 tmp = withTestChatCfg tmp testCfgV1
|
|
|
|
withTestChat :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChat tmp = withTestChatCfgOpts tmp testCfg testOpts
|
|
|
|
withTestChatCfg :: HasCallStack => FilePath -> ChatConfig -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatCfg tmp cfg = withTestChatCfgOpts tmp cfg testOpts
|
|
|
|
withTestChatOpts :: HasCallStack => FilePath -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatOpts tmp = withTestChatCfgOpts tmp testCfg
|
|
|
|
withTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatCfgOpts tmp cfg opts dbPrefix = bracket (startTestChat tmp cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
|
|
|
|
-- enable output for specific chat controller, use like this:
|
|
-- withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do ...
|
|
withTestOutput :: HasCallStack => TestCC -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestOutput cc runTest = runTest cc {printOutput = True}
|
|
|
|
readTerminalOutput :: VirtualTerminal -> TQueue String -> IO ()
|
|
readTerminalOutput t termQ = do
|
|
let w = virtualWindow t
|
|
winVar <- atomically $ newTVar . init =<< readTVar w
|
|
forever . atomically $ do
|
|
win <- readTVar winVar
|
|
win' <- init <$> readTVar w
|
|
if win' == win
|
|
then retry
|
|
else do
|
|
let diff = getDiff win' win
|
|
forM_ diff $ writeTQueue termQ
|
|
writeTVar winVar win'
|
|
where
|
|
getDiff :: [String] -> [String] -> [String]
|
|
getDiff win win' = getDiff_ 1 (length win) win win'
|
|
getDiff_ :: Int -> Int -> [String] -> [String] -> [String]
|
|
getDiff_ n len win' win =
|
|
let diff = drop (len - n) win'
|
|
in if drop n win <> diff == win'
|
|
then map (dropWhileEnd (== ' ')) diff
|
|
else getDiff_ (n + 1) len win' win
|
|
|
|
withTmpFiles :: IO () -> IO ()
|
|
withTmpFiles =
|
|
bracket_
|
|
(createDirectoryIfMissing False "tests/tmp")
|
|
(removeDirectoryRecursive "tests/tmp")
|
|
|
|
testChatN :: HasCallStack => ChatConfig -> ChatOpts -> [Profile] -> (HasCallStack => [TestCC] -> IO ()) -> FilePath -> IO ()
|
|
testChatN cfg opts ps test tmp = do
|
|
tcs <- getTestCCs (zip ps [1 ..]) []
|
|
test tcs
|
|
concurrentlyN_ $ map (<// 100000) tcs
|
|
concurrentlyN_ $ map stopTestChat tcs
|
|
where
|
|
getTestCCs :: [(Profile, Int)] -> [TestCC] -> IO [TestCC]
|
|
getTestCCs [] tcs = pure tcs
|
|
getTestCCs ((p, db) : envs') tcs = (:) <$> createTestChat tmp cfg opts (show db) p <*> getTestCCs envs' tcs
|
|
|
|
(<//) :: HasCallStack => TestCC -> Int -> Expectation
|
|
(<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing
|
|
|
|
getTermLine :: HasCallStack => TestCC -> IO String
|
|
getTermLine cc =
|
|
5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case
|
|
Just s -> do
|
|
-- remove condition to always echo virtual terminal
|
|
when (printOutput cc) $ do
|
|
-- when True $ do
|
|
name <- userName cc
|
|
putStrLn $ name <> ": " <> s
|
|
pure s
|
|
_ -> error "no output for 5 seconds"
|
|
|
|
userName :: TestCC -> IO [Char]
|
|
userName (TestCC ChatController {currentUser} _ _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser
|
|
|
|
testChat2 :: HasCallStack => Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
testChat2 = testChatCfgOpts2 testCfg testOpts
|
|
|
|
testChatCfg2 :: HasCallStack => ChatConfig -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
testChatCfg2 cfg = testChatCfgOpts2 cfg testOpts
|
|
|
|
testChatOpts2 :: HasCallStack => ChatOpts -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
testChatOpts2 = testChatCfgOpts2 testCfg
|
|
|
|
testChatCfgOpts2 :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> 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 ()) -> FilePath -> IO ()
|
|
testChat3 = testChatCfgOpts3 testCfg testOpts
|
|
|
|
testChatCfg3 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
testChatCfg3 cfg = testChatCfgOpts3 cfg testOpts
|
|
|
|
testChatCfgOpts3 :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> 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 ()) -> FilePath -> IO ()
|
|
testChat4 = testChatCfg4 testCfg
|
|
|
|
testChatCfg4 :: HasCallStack => ChatConfig -> Profile -> Profile -> Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
testChatCfg4 cfg p1 p2 p3 p4 test = testChatN cfg testOpts [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"
|
|
|
|
concurrentlyN_ :: [IO a] -> IO ()
|
|
concurrentlyN_ = mapConcurrently_ id
|
|
|
|
serverCfg :: ServerConfig
|
|
serverCfg =
|
|
ServerConfig
|
|
{ transports = [(serverPort, transport @TLS)],
|
|
tbqSize = 1,
|
|
-- serverTbqSize = 1,
|
|
msgQueueQuota = 16,
|
|
queueIdBytes = 12,
|
|
msgIdBytes = 6,
|
|
storeLogFile = Nothing,
|
|
storeMsgsFile = Nothing,
|
|
allowNewQueues = True,
|
|
-- server password is disabled as otherwise v1 tests fail
|
|
newQueueBasicAuth = Nothing, -- Just "server_password",
|
|
messageExpiration = Just defaultMessageExpiration,
|
|
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
|
caCertificateFile = "tests/fixtures/tls/ca.crt",
|
|
privateKeyFile = "tests/fixtures/tls/server.key",
|
|
certificateFile = "tests/fixtures/tls/server.crt",
|
|
logStatsInterval = Nothing,
|
|
logStatsStartTime = 0,
|
|
serverStatsLogFile = "tests/smp-server-stats.daily.log",
|
|
serverStatsBackupFile = Nothing,
|
|
smpServerVRange = supportedSMPServerVRange,
|
|
transportConfig = defaultTransportServerConfig,
|
|
controlPort = Nothing
|
|
}
|
|
|
|
withSmpServer :: IO () -> IO ()
|
|
withSmpServer = serverBracket (`runSMPServerBlocking` serverCfg)
|
|
|
|
xftpTestPort :: ServiceName
|
|
xftpTestPort = "7002"
|
|
|
|
xftpServerFiles :: FilePath
|
|
xftpServerFiles = "tests/tmp/xftp-server-files"
|
|
|
|
xftpServerConfig :: XFTPServerConfig
|
|
xftpServerConfig =
|
|
XFTPServerConfig
|
|
{ xftpPort = xftpTestPort,
|
|
fileIdSize = 16,
|
|
storeLogFile = Just "tests/tmp/xftp-server-store.log",
|
|
filesPath = xftpServerFiles,
|
|
fileSizeQuota = Nothing,
|
|
allowedChunkSizes = [kb 128, kb 256, mb 1, mb 4],
|
|
allowNewFiles = True,
|
|
newFileBasicAuth = Nothing,
|
|
fileExpiration = Just defaultFileExpiration,
|
|
caCertificateFile = "tests/fixtures/tls/ca.crt",
|
|
privateKeyFile = "tests/fixtures/tls/server.key",
|
|
certificateFile = "tests/fixtures/tls/server.crt",
|
|
logStatsInterval = Nothing,
|
|
logStatsStartTime = 0,
|
|
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
|
|
serverStatsBackupFile = Nothing,
|
|
transportConfig = defaultTransportServerConfig
|
|
}
|
|
|
|
withXFTPServer :: IO () -> IO ()
|
|
withXFTPServer = withXFTPServer' xftpServerConfig
|
|
|
|
withXFTPServer' :: XFTPServerConfig -> IO () -> IO ()
|
|
withXFTPServer' cfg =
|
|
serverBracket
|
|
( \started -> do
|
|
createDirectoryIfMissing False xftpServerFiles
|
|
runXFTPServerBlocking started cfg
|
|
)
|
|
|
|
serverBracket :: (TMVar Bool -> IO ()) -> IO () -> IO ()
|
|
serverBracket server f = do
|
|
started <- newEmptyTMVarIO
|
|
bracket
|
|
(forkIOWithUnmask ($ server started))
|
|
(\t -> killThread t >> waitFor started "stop")
|
|
(\_ -> waitFor started "start" >> f)
|
|
where
|
|
waitFor started s =
|
|
5000000 `timeout` atomically (takeTMVar started) >>= \case
|
|
Nothing -> error $ "server did not " <> s
|
|
_ -> pure ()
|