mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
599 lines
27 KiB
Haskell
599 lines
27 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module ChatTests.Utils where
|
|
|
|
import ChatClient
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.Async (concurrently_)
|
|
import Control.Concurrent.STM
|
|
import Control.Monad (unless, when)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Char (isDigit)
|
|
import Data.List (isPrefixOf, isSuffixOf)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.String
|
|
import qualified Data.Text as T
|
|
import Database.SQLite.Simple (Only (..))
|
|
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig)
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Store.Profiles (getUserContactProfiles)
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Preferences
|
|
import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow, withTransaction)
|
|
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Version
|
|
import System.Directory (doesFileExist)
|
|
import System.Environment (lookupEnv)
|
|
import System.FilePath ((</>))
|
|
import System.Info (os)
|
|
import Test.Hspec
|
|
|
|
defaultPrefs :: Maybe Preferences
|
|
defaultPrefs = Just $ toChatPrefs defaultChatPrefs
|
|
|
|
aliceDesktopProfile :: Profile
|
|
aliceDesktopProfile = Profile {displayName = "alice_desktop", fullName = "Alice Desktop", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
|
|
|
|
aliceProfile :: Profile
|
|
aliceProfile = Profile {displayName = "alice", fullName = "Alice", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
|
|
|
|
bobProfile :: Profile
|
|
bobProfile = Profile {displayName = "bob", fullName = "Bob", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAKHGlDQ1BJQ0MgUHJvZmlsZQAASImFVgdUVNcWve9Nb7QZeu9NehtAem/Sq6gMQ28OQxWxgAQjEFFEREARNFQFg1KjiIhiIQgoYA9IEFBisCAq6OQNJNH4//r/zDpz9ttzz7n73ffWmg0A6QCDxYqD+QCIT0hmezlYywQEBsngngEYCAIy0AC6DGYSy8rDwxUg8Xf9d7wbAxC33tHgzvrP3/9nCISFJzEBgIIRTGey2MkILkawT1oyi4tnEUxjI6IQvMLFkauYqxjQQtewwuoaHy8bBNMBwJMZDHYkAERbhJdJZUYic4hhCNZOCItOQDB3vjkzioFwxLsIXhcRl5IOAImrRzs+fivCk7QRrIL0shAcwNUW+tX8yH/tFfrPXgxG5D84Pi6F+dc9ck+HHJ7g641UMSQlQATQBHEgBaQDGcACbLAVYaIRJhx5Dv+9j77aZ4OsZIFtSEc0iARRIBnpt/9qlvfqpGSQBhjImnCEcUU+NtxnujZy4fbqVEiU/wuXdQyA9S0cDqfzC+e2F4DzyLkSB79wyi0A8KoBcL2GmcJOXePQ3C8MIAJeQAOiQArIAxXuWwMMgSmwBHbAGbgDHxAINgMmojceUZUGMkEWyAX54AA4DMpAJTgJ6sAZ0ALawQVwGVwDt8AQGAUPwQSYBi/AAngHliEIwkEUiAqJQtKQIqQO6UJ0yByyg1whLygQCoEioQQoBcqE9kD5UBFUBlVB9dBPUCd0GboBDUP3oUloDnoNfYRRMBmmwZKwEqwF02Er2AX2gTfBkXAinAHnwPvhUrgaPg23wZfhW/AoPAG/gBdRAEVCCaFkURooOsoG5Y4KQkWg2KidqDxUCaoa1YTqQvWj7qAmUPOoD2gsmoqWQWugTdGOaF80E52I3okuQJeh69Bt6D70HfQkegH9GUPBSGDUMSYYJ0wAJhKThsnFlGBqMK2Yq5hRzDTmHRaLFcIqY42wjthAbAx2O7YAewzbjO3BDmOnsIs4HE4Up44zw7njGLhkXC7uKO407hJuBDeNe48n4aXxunh7fBA+AZ+NL8E34LvxI/gZ/DKBj6BIMCG4E8II2wiFhFOELsJtwjRhmchPVCaaEX2IMcQsYimxiXiV+Ij4hkQiyZGMSZ6kaNJuUinpLOk6aZL0gSxAViPbkIPJKeT95FpyD/k++Q2FQlGiWFKCKMmU/ZR6yhXKE8p7HiqPJo8TTxjPLp5ynjaeEZ6XvAReRV4r3s28GbwlvOd4b/PO8xH4lPhs+Bh8O/nK+Tr5xvkW+an8Ovzu/PH8BfwN/Df4ZwVwAkoCdgJhAjkCJwWuCExRUVR5qg2VSd1DPUW9Sp2mYWnKNCdaDC2fdoY2SFsQFBDUF/QTTBcsF7woOCGEElISchKKEyoUahEaE/ooLClsJRwuvE+4SXhEeElEXMRSJFwkT6RZZFTko6iMqJ1orOhB0XbRx2JoMTUxT7E0seNiV8XmxWnipuJM8TzxFvEHErCEmoSXxHaJkxIDEouSUpIOkizJo5JXJOelhKQspWKkiqW6peakqdLm0tHSxdKXpJ/LCMpYycTJlMr0ySzISsg6yqbIVskOyi7LKcv5ymXLNcs9lifK0+Uj5Ivle+UXFKQV3BQyFRoVHigSFOmKUYpHFPsVl5SUlfyV9iq1K80qiyg7KWcoNyo/UqGoWKgkqlSr3FXFqtJVY1WPqQ6pwWoGalFq5Wq31WF1Q/Vo9WPqw+sw64zXJayrXjeuQdaw0kjVaNSY1BTSdNXM1mzXfKmloBWkdVCrX+uztoF2nPYp7Yc6AjrOOtk6XTqvddV0mbrlunf1KHr2erv0OvRe6avrh+sf179nQDVwM9hr0GvwydDIkG3YZDhnpGAUYlRhNE6n0T3oBfTrxhhja+NdxheMP5gYmiSbtJj8YaphGmvaYDq7Xnl9+PpT66fM5MwYZlVmE+Yy5iHmJ8wnLGQtGBbVFk8t5S3DLGssZ6xUrWKsTlu9tNa2Zlu3Wi/ZmNjssOmxRdk62ObZDtoJ2Pnaldk9sZezj7RvtF9wMHDY7tDjiHF0cTzoOO4k6cR0qndacDZy3uHc50J28XYpc3nqqubKdu1yg92c3Q65PdqguCFhQ7s7cHdyP+T+2EPZI9HjZ0+sp4dnueczLx2vTK9+b6r3Fu8G73c+1j6FPg99VXxTfHv9eP2C/er9lvxt/Yv8JwK0AnYE3AoUC4wO7AjCBfkF1QQtbrTbeHjjdLBBcG7w2CblTembbmwW2xy3+eIW3i2MLedCMCH+IQ0hKwx3RjVjMdQptCJ0gWnDPMJ8EWYZVhw2F24WXhQ+E2EWURQxG2kWeShyLsoiqiRqPtomuiz6VYxjTGXMUqx7bG0sJ84/rjkeHx8S35kgkBCb0LdVamv61mGWOiuXNZFokng4cYHtwq5JgpI2JXUk05A/0oEUlZTvUiZTzVPLU9+n+aWdS+dPT0gf2Ka2bd+2mQz7jB+3o7czt/dmymZmZU7usNpRtRPaGbqzd5f8rpxd07sddtdlEbNis37J1s4uyn67x39PV45kzu6cqe8cvmvM5cll547vNd1b+T36++jvB/fp7Tu673NeWN7NfO38kvyVAmbBzR90fij9gbM/Yv9goWHh8QPYAwkHxg5aHKwr4i/KKJo65HaorVimOK/47eEth2+U6JdUHiEeSTkyUepa2nFU4eiBoytlUWWj5dblzRUSFfsqlo6FHRs5bnm8qVKyMr/y44noE/eqHKraqpWqS05iT6aefHbK71T/j/Qf62vEavJrPtUm1E7UedX11RvV1zdINBQ2wo0pjXOng08PnbE909Gk0VTVLNScfxacTTn7/KeQn8ZaXFp6z9HPNZ1XPF/RSm3Na4PatrUttEe1T3QEdgx3Onf2dpl2tf6s+XPtBdkL5RcFLxZ2E7tzujmXMi4t9rB65i9HXp7q3dL78ErAlbt9nn2DV12uXr9mf+1Kv1X/petm1y/cMLnReZN+s/2W4a22AYOB1l8MfmkdNBxsu210u2PIeKhreP1w94jFyOU7tneu3XW6e2t0w+jwmO/YvfHg8Yl7Yfdm78fdf/Ug9cHyw92PMI/yHvM9Lnki8aT6V9VfmycMJy5O2k4OPPV++nCKOfXit6TfVqZznlGelcxIz9TP6s5emLOfG3q+8fn0C9aL5fnc3/l/r3ip8vL8H5Z/DCwELEy/Yr/ivC54I/qm9q3+295Fj8Un7+LfLS/lvRd9X/eB/qH/o//HmeW0FdxK6SfVT12fXT4/4sRzOCwGm7FqBVBIwhERALyuBYASCAB1CPEPG9f8119+BvrK2fyNwVndL5jhvubRVsMQgCakeCFp04OsQ1LJEgAe5NodqT6WANbT+yf/iqQIPd21PXgaAcDJcjivtwJAQHLFgcNZ9uBwPlUgYhHf1z37f7V9g9e8ITewiP88wfWIYET6HPg21nzjV2fybQVcxfrg2/onng/F50lD/ccAAAA4ZVhJZk1NACoAAAAIAAGHaQAEAAAAAQAAABoAAAAAAAKgAgAEAAAAAQAAABigAwAEAAAAAQAAABgAAAAAwf1XlwAAAaNJREFUSA3FlT1LA0EQQBN/gYUYRTksJZVgEbCR/D+7QMr8ABtttBBCsLGzsLG2sxaxED/ie4d77u0dyaE5HHjczn7MzO7M7nU6/yXz+bwLhzCCjTQO+rZhDH3opuNLdRYN4RHe4RIKJ7R34Ro+4AEGSw2mE1iUwT18gpI74WvkGlccu4XNdH0jnYU7cAUacidn37qR23cOxc4aGU0nYUAn7iSWEHkz46w0ocdQu1X6B/AMQZ5o7KfBqNOfwRH8JB7FajGhnmcpKvQe3MEbvILiDm5gPXaCHnZr4vvFGMoEKudKn8YvQIOOe+YzCPop7dwJ3zRfJ7GDuso4YJGRa0yZgg4tUaNXdGrbuZWKKxzYYEJc2xp9AUUjGt8KC2jvgYadF8+10vJyDnNLXwbdiWUZi0fUK01Eoc+AZhCLZVzK4Vq6sDUdz+0dEcbbTTIOJmAyTVhx/WmvrExbv2jtPhWLKodjCtefZiEeZeVZWWSndgwj6fVf3XON8Qwq15++uoqrfYVrow6dGBpCq79ME291jaB0/Q2CPncyht/99MNO/vr9AqW/CGi8sJqbAAAAAElFTkSuQmCC"), contactLink = Nothing, preferences = defaultPrefs}
|
|
|
|
cathProfile :: Profile
|
|
cathProfile = Profile {displayName = "cath", fullName = "Catherine", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
|
|
|
|
danProfile :: Profile
|
|
danProfile = Profile {displayName = "dan", fullName = "Daniel", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
|
|
|
|
xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
|
|
xit' = if os == "linux" then xit else it
|
|
|
|
xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
|
|
xit'' = ifCI xit it
|
|
|
|
xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a
|
|
xdescribe'' = ifCI xdescribe describe
|
|
|
|
ifCI :: HasCallStack => (HasCallStack => String -> a -> SpecWith b) -> (HasCallStack => String -> a -> SpecWith b) -> String -> a -> SpecWith b
|
|
ifCI xrun run d t = do
|
|
ci <- runIO $ lookupEnv "CI"
|
|
(if ci == Just "true" then xrun else run) d t
|
|
|
|
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
|
versionTestMatrix2 runTest = do
|
|
it "v2" $ testChat2 aliceProfile bobProfile runTest
|
|
it "v1" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
|
|
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
|
|
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
|
|
|
|
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
|
-- versionTestMatrix3 runTest = do
|
|
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
|
|
|
|
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
|
|
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
|
|
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest
|
|
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest
|
|
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
|
|
|
|
inlineCfg :: Integer -> ChatConfig
|
|
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}}
|
|
|
|
fileTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
|
fileTestMatrix2 runTest = do
|
|
it "via connection" $ runTestCfg2 viaConn viaConn runTest
|
|
it "inline (accepting)" $ runTestCfg2 inline inline runTest
|
|
it "via connection (inline offered)" $ runTestCfg2 inline viaConn runTest
|
|
it "via connection (inline supported)" $ runTestCfg2 viaConn inline runTest
|
|
where
|
|
inline = inlineCfg 100
|
|
viaConn = inlineCfg 0
|
|
|
|
fileTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
|
fileTestMatrix3 runTest = do
|
|
it "via connection" $ runTestCfg3 viaConn viaConn viaConn runTest
|
|
it "inline" $ runTestCfg3 inline inline inline runTest
|
|
it "via connection (inline offered)" $ runTestCfg3 inline viaConn viaConn runTest
|
|
it "via connection (inline supported)" $ runTestCfg3 viaConn inline inline runTest
|
|
where
|
|
inline = inlineCfg 100
|
|
viaConn = inlineCfg 0
|
|
|
|
runTestCfg2 :: ChatConfig -> ChatConfig -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
runTestCfg2 aliceCfg bobCfg runTest tmp =
|
|
withNewTestChatCfg tmp aliceCfg "alice" aliceProfile $ \alice ->
|
|
withNewTestChatCfg tmp bobCfg "bob" bobProfile $ \bob ->
|
|
runTest alice bob
|
|
|
|
runTestCfg3 :: ChatConfig -> ChatConfig -> ChatConfig -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
|
|
runTestCfg3 aliceCfg bobCfg cathCfg runTest tmp =
|
|
withNewTestChatCfg tmp aliceCfg "alice" aliceProfile $ \alice ->
|
|
withNewTestChatCfg tmp bobCfg "bob" bobProfile $ \bob ->
|
|
withNewTestChatCfg tmp cathCfg "cath" cathProfile $ \cath ->
|
|
runTest alice bob cath
|
|
|
|
withTestChatGroup3Connected :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatGroup3Connected tmp dbPrefix action = do
|
|
withTestChat tmp dbPrefix $ \cc -> do
|
|
cc <## "2 contacts connected (use /cs for the list)"
|
|
cc <## "#team: connected to server(s)"
|
|
action cc
|
|
|
|
withTestChatGroup3Connected' :: HasCallStack => FilePath -> String -> IO ()
|
|
withTestChatGroup3Connected' tmp dbPrefix = withTestChatGroup3Connected tmp dbPrefix $ \_ -> pure ()
|
|
|
|
withTestChatContactConnected :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatContactConnected tmp dbPrefix action =
|
|
withTestChat tmp dbPrefix $ \cc -> do
|
|
cc <## "1 contacts connected (use /cs for the list)"
|
|
action cc
|
|
|
|
withTestChatContactConnected' :: HasCallStack => FilePath -> String -> IO ()
|
|
withTestChatContactConnected' tmp dbPrefix = withTestChatContactConnected tmp dbPrefix $ \_ -> pure ()
|
|
|
|
withTestChatContactConnectedV1 :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
|
|
withTestChatContactConnectedV1 tmp dbPrefix action =
|
|
withTestChatV1 tmp dbPrefix $ \cc -> do
|
|
cc <## "1 contacts connected (use /cs for the list)"
|
|
action cc
|
|
|
|
withTestChatContactConnectedV1' :: HasCallStack => FilePath -> String -> IO ()
|
|
withTestChatContactConnectedV1' tmp dbPrefix = withTestChatContactConnectedV1 tmp dbPrefix $ \_ -> pure ()
|
|
|
|
-- | test sending direct messages
|
|
(<##>) :: HasCallStack => TestCC -> TestCC -> IO ()
|
|
cc1 <##> cc2 = do
|
|
name1 <- userName cc1
|
|
name2 <- userName cc2
|
|
cc1 #> ("@" <> name2 <> " hi")
|
|
cc2 <# (name1 <> "> hi")
|
|
cc2 #> ("@" <> name1 <> " hey")
|
|
cc1 <# (name2 <> "> hey")
|
|
|
|
(##>) :: HasCallStack => TestCC -> String -> IO ()
|
|
cc ##> cmd = do
|
|
cc `send` cmd
|
|
cc <## cmd
|
|
|
|
(#>) :: HasCallStack => TestCC -> String -> IO ()
|
|
cc #> cmd = do
|
|
cc `send` cmd
|
|
cc <# cmd
|
|
|
|
(?#>) :: HasCallStack => TestCC -> String -> IO ()
|
|
cc ?#> cmd = do
|
|
cc `send` cmd
|
|
cc <# ("i " <> cmd)
|
|
|
|
(#$>) :: (Eq a, Show a, HasCallStack) => TestCC -> (String, String -> a, a) -> Expectation
|
|
cc #$> (cmd, f, res) = do
|
|
cc ##> cmd
|
|
(f <$> getTermLine cc) `shouldReturn` res
|
|
|
|
chat :: String -> [(Int, String)]
|
|
chat = map (\(a, _, _) -> a) . chat''
|
|
|
|
chat' :: String -> [((Int, String), Maybe (Int, String))]
|
|
chat' = map (\(a, b, _) -> (a, b)) . chat''
|
|
|
|
chatF :: String -> [((Int, String), Maybe String)]
|
|
chatF = map (\(a, _, c) -> (a, c)) . chat''
|
|
|
|
chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)]
|
|
chat'' = read
|
|
|
|
chatFeatures :: [(Int, String)]
|
|
chatFeatures = map (\(a, _, _) -> a) chatFeatures''
|
|
|
|
chatFeatures' :: [((Int, String), Maybe (Int, String))]
|
|
chatFeatures' = map (\(a, b, _) -> (a, b)) chatFeatures''
|
|
|
|
chatFeaturesF :: [((Int, String), Maybe String)]
|
|
chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures''
|
|
|
|
chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
|
|
chatFeatures'' =
|
|
[ ((0, "Disappearing messages: allowed"), Nothing, Nothing),
|
|
((0, "Full deletion: off"), Nothing, Nothing),
|
|
((0, "Message reactions: enabled"), Nothing, Nothing),
|
|
((0, "Voice messages: enabled"), Nothing, Nothing),
|
|
((0, "Audio/video calls: enabled"), Nothing, Nothing)
|
|
]
|
|
|
|
lastChatFeature :: String
|
|
lastChatFeature = snd $ last chatFeatures
|
|
|
|
groupFeatures :: [(Int, String)]
|
|
groupFeatures = map (\(a, _, _) -> a) groupFeatures''
|
|
|
|
groupFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
|
|
groupFeatures'' =
|
|
[ ((0, "Disappearing messages: off"), Nothing, Nothing),
|
|
((0, "Direct messages: on"), Nothing, Nothing),
|
|
((0, "Full deletion: off"), Nothing, Nothing),
|
|
((0, "Message reactions: on"), Nothing, Nothing),
|
|
((0, "Voice messages: on"), Nothing, Nothing),
|
|
((0, "Files and media: on"), Nothing, Nothing)
|
|
]
|
|
|
|
itemId :: Int -> String
|
|
itemId i = show $ length chatFeatures + i
|
|
|
|
(@@@) :: HasCallStack => TestCC -> [(String, String)] -> Expectation
|
|
(@@@) cc res = do
|
|
threadDelay 10000
|
|
getChats mapChats cc res
|
|
|
|
mapChats :: [(String, String, Maybe ConnStatus)] -> [(String, String)]
|
|
mapChats = map $ \(ldn, msg, _) -> (ldn, msg)
|
|
|
|
chats :: String -> [(String, String)]
|
|
chats = mapChats . read
|
|
|
|
(@@@!) :: HasCallStack => TestCC -> [(String, String, Maybe ConnStatus)] -> Expectation
|
|
(@@@!) = getChats id
|
|
|
|
getChats :: HasCallStack => (Eq a, Show a) => ([(String, String, Maybe ConnStatus)] -> [a]) -> TestCC -> [a] -> Expectation
|
|
getChats f cc res = do
|
|
cc ##> "/_get chats 1 pcc=on"
|
|
line <- getTermLine cc
|
|
f (read line) `shouldMatchList` res
|
|
|
|
send :: TestCC -> String -> IO ()
|
|
send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) cmd
|
|
|
|
(<##) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc <## line = do
|
|
l <- getTermLine cc
|
|
when (l /= line) $ print ("expected: " <> line, ", got: " <> l)
|
|
l `shouldBe` line
|
|
|
|
(<##.) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc <##. line = do
|
|
l <- getTermLine cc
|
|
let prefix = line `isPrefixOf` l
|
|
unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
|
|
prefix `shouldBe` True
|
|
|
|
(.<##) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc .<## line = do
|
|
l <- getTermLine cc
|
|
let suffix = line `isSuffixOf` l
|
|
unless suffix $ print ("expected to end with: " <> line, ", got: " <> l)
|
|
suffix `shouldBe` True
|
|
|
|
(<#.) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc <#. line = do
|
|
l <- dropTime <$> getTermLine cc
|
|
let prefix = line `isPrefixOf` l
|
|
unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
|
|
prefix `shouldBe` True
|
|
|
|
(<##..) :: HasCallStack => TestCC -> [String] -> Expectation
|
|
cc <##.. ls = do
|
|
l <- getTermLine cc
|
|
let prefix = any (`isPrefixOf` l) ls
|
|
unless prefix $ print ("expected to start from one of: " <> show ls, ", got: " <> l)
|
|
prefix `shouldBe` True
|
|
|
|
data ConsoleResponse
|
|
= ConsoleString String
|
|
| WithTime String
|
|
| EndsWith String
|
|
| StartsWith String
|
|
| Predicate (String -> Bool)
|
|
|
|
instance IsString ConsoleResponse where fromString = ConsoleString
|
|
|
|
-- this assumes that the string can only match one option
|
|
getInAnyOrder :: HasCallStack => (String -> String) -> TestCC -> [ConsoleResponse] -> Expectation
|
|
getInAnyOrder _ _ [] = pure ()
|
|
getInAnyOrder f cc ls = do
|
|
line <- f <$> getTermLine cc
|
|
let rest = filterFirst (expected line) ls
|
|
if length rest < length ls
|
|
then getInAnyOrder f cc rest
|
|
else error $ "unexpected output: " <> line
|
|
where
|
|
expected :: String -> ConsoleResponse -> Bool
|
|
expected l = \case
|
|
ConsoleString s -> l == s
|
|
WithTime s -> dropTime_ l == Just s
|
|
EndsWith s -> s `isSuffixOf` l
|
|
StartsWith s -> s `isPrefixOf` l
|
|
Predicate p -> p l
|
|
filterFirst :: (a -> Bool) -> [a] -> [a]
|
|
filterFirst _ [] = []
|
|
filterFirst p (x : xs)
|
|
| p x = xs
|
|
| otherwise = x : filterFirst p xs
|
|
|
|
(<###) :: HasCallStack => TestCC -> [ConsoleResponse] -> Expectation
|
|
(<###) = getInAnyOrder id
|
|
|
|
(<##?) :: HasCallStack => TestCC -> [ConsoleResponse] -> Expectation
|
|
(<##?) = getInAnyOrder dropTime
|
|
|
|
(<#) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line
|
|
|
|
(*<#) :: HasCallStack => [TestCC] -> String -> Expectation
|
|
ccs *<# line = concurrentlyN_ $ map (<# line) ccs
|
|
|
|
(?<#) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line
|
|
|
|
($<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
|
|
(cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine cc) `shouldReturn` line
|
|
|
|
(^<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
|
|
(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine cc) `shouldReturn` line
|
|
|
|
(⩗) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc ⩗ line = (dropTime . dropReceipt <$> getTermLine cc) `shouldReturn` line
|
|
|
|
(%) :: HasCallStack => TestCC -> String -> Expectation
|
|
cc % line = (dropTime . dropPartialReceipt <$> getTermLine cc) `shouldReturn` line
|
|
|
|
(</) :: HasCallStack => TestCC -> Expectation
|
|
(</) = (<// 500000)
|
|
|
|
(<#?) :: HasCallStack => TestCC -> TestCC -> Expectation
|
|
cc1 <#? cc2 = do
|
|
name <- userName cc2
|
|
sName <- showName cc2
|
|
cc2 <## "connection request sent!"
|
|
cc1 <## (sName <> " wants to connect to you!")
|
|
cc1 <## ("to accept: /ac " <> name)
|
|
cc1 <## ("to reject: /rc " <> name <> " (the sender will NOT be notified)")
|
|
|
|
dropUser :: HasCallStack => String -> String -> String
|
|
dropUser uName msg = fromMaybe err $ dropUser_ uName msg
|
|
where
|
|
err = error $ "invalid user: " <> msg
|
|
|
|
dropUser_ :: String -> String -> Maybe String
|
|
dropUser_ uName msg = do
|
|
let userPrefix = "[user: " <> uName <> "] "
|
|
if userPrefix `isPrefixOf` msg
|
|
then Just $ drop (length userPrefix) msg
|
|
else Nothing
|
|
|
|
dropTime :: HasCallStack => String -> String
|
|
dropTime msg = fromMaybe err $ dropTime_ msg
|
|
where
|
|
err = error $ "invalid time: " <> msg
|
|
|
|
dropTime_ :: String -> Maybe String
|
|
dropTime_ msg = case splitAt 6 msg of
|
|
([m, m', ':', s, s', ' '], text) ->
|
|
if all isDigit [m, m', s, s'] then Just text else Nothing
|
|
_ -> Nothing
|
|
|
|
dropStrPrefix :: HasCallStack => String -> String -> String
|
|
dropStrPrefix pfx s =
|
|
let (p, rest) = splitAt (length pfx) s
|
|
in if p == pfx then rest else error $ "no prefix " <> pfx <> " in string : " <> s
|
|
|
|
dropReceipt :: HasCallStack => String -> String
|
|
dropReceipt msg = fromMaybe err $ dropReceipt_ msg
|
|
where
|
|
err = error $ "invalid receipt: " <> msg
|
|
|
|
dropReceipt_ :: String -> Maybe String
|
|
dropReceipt_ msg = case splitAt 2 msg of
|
|
("⩗ ", text) -> Just text
|
|
_ -> Nothing
|
|
|
|
dropPartialReceipt :: HasCallStack => String -> String
|
|
dropPartialReceipt msg = fromMaybe err $ dropPartialReceipt_ msg
|
|
where
|
|
err = error $ "invalid partial receipt: " <> msg
|
|
|
|
dropPartialReceipt_ :: String -> Maybe String
|
|
dropPartialReceipt_ msg = case splitAt 2 msg of
|
|
("% ", text) -> Just text
|
|
_ -> Nothing
|
|
|
|
getInvitation :: HasCallStack => TestCC -> IO String
|
|
getInvitation cc = do
|
|
cc <## "pass this invitation link to your contact (via another channel):"
|
|
cc <## ""
|
|
inv <- getTermLine cc
|
|
cc <## ""
|
|
cc <## "and ask them to connect: /c <invitation_link_above>"
|
|
pure inv
|
|
|
|
getContactLink :: HasCallStack => TestCC -> Bool -> IO String
|
|
getContactLink cc created = do
|
|
cc <## if created then "Your new chat address is created!" else "Your chat address:"
|
|
cc <## ""
|
|
link <- getTermLine cc
|
|
cc <## ""
|
|
cc <## "Anybody can send you contact requests with: /c <contact_link_above>"
|
|
cc <## "to show it again: /sa"
|
|
cc <## "to share with your contacts: /profile_address on"
|
|
cc <## "to delete it: /da (accepted contacts will remain connected)"
|
|
pure link
|
|
|
|
getGroupLink :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> IO String
|
|
getGroupLink cc gName mRole created = do
|
|
cc <## if created then "Group link is created!" else "Group link:"
|
|
cc <## ""
|
|
link <- getTermLine cc
|
|
cc <## ""
|
|
cc <## ("Anybody can connect to you and join group as " <> B.unpack (strEncode mRole) <> " with: /c <group_link_above>")
|
|
cc <## ("to show it again: /show link #" <> gName)
|
|
cc <## ("to delete it: /delete link #" <> gName <> " (joined members will remain connected to you)")
|
|
pure link
|
|
|
|
hasContactProfiles :: HasCallStack => TestCC -> [ContactName] -> Expectation
|
|
hasContactProfiles cc names =
|
|
getContactProfiles cc >>= \ps -> ps `shouldMatchList` names
|
|
|
|
getContactProfiles :: TestCC -> IO [ContactName]
|
|
getContactProfiles cc = do
|
|
user_ <- readTVarIO (currentUser $ chatController cc)
|
|
case user_ of
|
|
Nothing -> pure []
|
|
Just user -> do
|
|
profiles <- withTransaction (chatStore $ chatController cc) $ \db -> getUserContactProfiles db user
|
|
pure $ map (\Profile {displayName} -> displayName) profiles
|
|
|
|
withCCUser :: TestCC -> (User -> IO a) -> IO a
|
|
withCCUser cc action = do
|
|
user_ <- readTVarIO (currentUser $ chatController cc)
|
|
case user_ of
|
|
Nothing -> error "no user"
|
|
Just user -> action user
|
|
|
|
withCCTransaction :: TestCC -> (DB.Connection -> IO a) -> IO a
|
|
withCCTransaction cc action =
|
|
withTransaction (chatStore $ chatController cc) $ \db -> action db
|
|
|
|
getProfilePictureByName :: TestCC -> String -> IO (Maybe String)
|
|
getProfilePictureByName cc displayName =
|
|
withTransaction (chatStore $ chatController cc) $ \db ->
|
|
maybeFirstRow fromOnly $
|
|
DB.query db "SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1" (Only displayName)
|
|
|
|
lastItemId :: HasCallStack => TestCC -> IO String
|
|
lastItemId cc = do
|
|
cc ##> "/last_item_id"
|
|
getTermLine cc
|
|
|
|
showActiveUser :: HasCallStack => TestCC -> String -> Expectation
|
|
showActiveUser cc name = do
|
|
cc <## ("user profile: " <> name)
|
|
cc <## "use /p <display name> to change it"
|
|
cc <## "(the updated profile will be sent to all your contacts)"
|
|
|
|
connectUsers :: HasCallStack => TestCC -> TestCC -> IO ()
|
|
connectUsers cc1 cc2 = do
|
|
name1 <- showName cc1
|
|
name2 <- showName cc2
|
|
cc1 ##> "/c"
|
|
inv <- getInvitation cc1
|
|
cc2 ##> ("/c " <> inv)
|
|
cc2 <## "confirmation sent!"
|
|
concurrently_
|
|
(cc2 <## (name1 <> ": contact is connected"))
|
|
(cc1 <## (name2 <> ": contact is connected"))
|
|
|
|
showName :: TestCC -> IO String
|
|
showName (TestCC ChatController {currentUser} _ _ _ _ _) = do
|
|
Just User {localDisplayName, profile = LocalProfile {fullName}} <- readTVarIO currentUser
|
|
pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName
|
|
|
|
createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO ()
|
|
createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 True
|
|
|
|
createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> Bool -> IO ()
|
|
createGroup2' gName cc1 cc2 doConnectUsers = do
|
|
when doConnectUsers $ connectUsers cc1 cc2
|
|
name2 <- userName cc2
|
|
cc1 ##> ("/g " <> gName)
|
|
cc1 <## ("group #" <> gName <> " is created")
|
|
cc1 <## ("to add members use /a " <> gName <> " <name> or /create link #" <> gName)
|
|
addMember gName cc1 cc2 GRAdmin
|
|
cc2 ##> ("/j " <> gName)
|
|
concurrently_
|
|
(cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group"))
|
|
(cc2 <## ("#" <> gName <> ": you joined the group"))
|
|
|
|
createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
|
|
createGroup3 gName cc1 cc2 cc3 = do
|
|
createGroup2 gName cc1 cc2
|
|
connectUsers cc1 cc3
|
|
name1 <- userName cc1
|
|
name3 <- userName cc3
|
|
sName2 <- showName cc2
|
|
sName3 <- showName cc3
|
|
addMember gName cc1 cc3 GRAdmin
|
|
cc3 ##> ("/j " <> gName)
|
|
concurrentlyN_
|
|
[ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"),
|
|
do
|
|
cc3 <## ("#" <> gName <> ": you joined the group")
|
|
cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"),
|
|
do
|
|
cc2 <## ("#" <> gName <> ": " <> name1 <> " added " <> sName3 <> " to the group (connecting...)")
|
|
cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected")
|
|
]
|
|
|
|
create2Groups3 :: HasCallStack => String -> String -> TestCC -> TestCC -> TestCC -> IO ()
|
|
create2Groups3 gName1 gName2 cc1 cc2 cc3 = do
|
|
createGroup3 gName1 cc1 cc2 cc3
|
|
createGroup2' gName2 cc1 cc2 False
|
|
name1 <- userName cc1
|
|
name3 <- userName cc3
|
|
addMember gName2 cc1 cc3 GRAdmin
|
|
cc3 ##> ("/j " <> gName2)
|
|
concurrentlyN_
|
|
[ cc1 <## ("#" <> gName2 <> ": " <> name3 <> " joined the group"),
|
|
do
|
|
cc3 <## ("#" <> gName2 <> ": you joined the group")
|
|
cc3 <##. ("#" <> gName2 <> ": member "), -- "#gName2: member sName2 is connected"
|
|
do
|
|
cc2 <##. ("#" <> gName2 <> ": " <> name1 <> " added ") -- "#gName2: name1 added sName3 to the group (connecting...)"
|
|
cc2 <##. ("#" <> gName2 <> ": new member ") -- "#gName2: new member name3 is connected"
|
|
]
|
|
|
|
addMember :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
|
addMember gName = fullAddMember gName ""
|
|
|
|
fullAddMember :: HasCallStack => String -> String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
|
fullAddMember gName fullName inviting invitee role = do
|
|
name1 <- userName inviting
|
|
memName <- userName invitee
|
|
inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role))
|
|
let fullName' = if null fullName || fullName == gName then "" else " (" <> fullName <> ")"
|
|
concurrentlyN_
|
|
[ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName),
|
|
do
|
|
invitee <## ("#" <> gName <> fullName' <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
|
|
invitee <## ("use /j " <> gName <> " to accept")
|
|
]
|
|
|
|
checkActionDeletesFile :: HasCallStack => FilePath -> IO () -> IO ()
|
|
checkActionDeletesFile file action = do
|
|
fileExistsBefore <- doesFileExist file
|
|
fileExistsBefore `shouldBe` True
|
|
action
|
|
fileExistsAfter <- doesFileExist file
|
|
fileExistsAfter `shouldBe` False
|
|
|
|
startFileTransferWithDest' :: HasCallStack => TestCC -> TestCC -> String -> String -> Maybe String -> IO ()
|
|
startFileTransferWithDest' cc1 cc2 fileName fileSize fileDest_ = do
|
|
name1 <- userName cc1
|
|
name2 <- userName cc2
|
|
cc1 #> ("/f @" <> name2 <> " ./tests/fixtures/" <> fileName)
|
|
cc1 <## "use /fc 1 to cancel sending"
|
|
cc2 <# (name1 <> "> sends file " <> fileName <> " (" <> fileSize <> ")")
|
|
cc2 <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
|
cc2 ##> ("/fr 1" <> maybe "" (" " <>) fileDest_)
|
|
cc2 <## ("saving file 1 from " <> name1 <> " to " <> maybe id (</>) fileDest_ fileName)
|
|
concurrently_
|
|
(cc2 <## ("started receiving file 1 (" <> fileName <> ") from " <> name1))
|
|
(cc1 <## ("started sending file 1 (" <> fileName <> ") to " <> name2))
|
|
|
|
currentChatVRangeInfo :: String
|
|
currentChatVRangeInfo =
|
|
"peer chat protocol version range: " <> vRangeStr supportedChatVRange
|
|
|
|
vRangeStr :: VersionRange -> String
|
|
vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxVer <> ")"
|
|
|
|
linkAnotherSchema :: String -> String
|
|
linkAnotherSchema link
|
|
| "https://simplex.chat/" `isPrefixOf` link =
|
|
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
|
|
| "simplex:/" `isPrefixOf` link =
|
|
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
|
|
| otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"
|