core: use duplex handshake (agent v2) (#735)
* core: use duplex handshake (agent v2) * version test matrix * update simplexmq
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
16bd9ccc4f
commit
716a941dc6
@@ -30,6 +30,7 @@ import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Server (runSMPServerBlocking)
|
||||
import Simplex.Messaging.Server.Env.STM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Version
|
||||
import System.Directory (createDirectoryIfMissing, removePathForcibly)
|
||||
import qualified System.Terminal as C
|
||||
import System.Terminal.Internal (VirtualTerminal (..), VirtualTerminalSettings (..), withVirtualTerminal)
|
||||
@@ -75,30 +76,42 @@ data TestCC = TestCC
|
||||
aCfg :: AgentConfig
|
||||
aCfg = agentConfig defaultChatConfig
|
||||
|
||||
cfg :: ChatConfig
|
||||
cfg =
|
||||
testAgentCfg :: AgentConfig
|
||||
testAgentCfg = aCfg {reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000}}
|
||||
|
||||
testCfg :: ChatConfig
|
||||
testCfg =
|
||||
defaultChatConfig
|
||||
{ agentConfig =
|
||||
aCfg {reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000}},
|
||||
{ agentConfig = testAgentCfg,
|
||||
testView = True
|
||||
}
|
||||
|
||||
createTestChat :: ChatOpts -> String -> Profile -> IO TestCC
|
||||
createTestChat opts dbPrefix profile = do
|
||||
testAgentCfgV1 :: AgentConfig
|
||||
testAgentCfgV1 =
|
||||
testAgentCfg
|
||||
{ smpAgentVersion = 1,
|
||||
smpAgentVRange = mkVersionRange 1 1
|
||||
}
|
||||
|
||||
testCfgV1 :: ChatConfig
|
||||
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
|
||||
|
||||
createTestChat :: ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
|
||||
createTestChat cfg opts dbPrefix profile = do
|
||||
let dbFilePrefix = testDBPrefix <> dbPrefix
|
||||
st <- createStore (dbFilePrefix <> "_chat.db") 1 False
|
||||
Right user <- runExceptT $ createUser st profile True
|
||||
startTestChat_ st opts dbFilePrefix user
|
||||
startTestChat_ st cfg opts dbFilePrefix user
|
||||
|
||||
startTestChat :: ChatOpts -> String -> IO TestCC
|
||||
startTestChat opts dbPrefix = do
|
||||
startTestChat :: ChatConfig -> ChatOpts -> String -> IO TestCC
|
||||
startTestChat cfg opts dbPrefix = do
|
||||
let dbFilePrefix = testDBPrefix <> dbPrefix
|
||||
st <- createStore (dbFilePrefix <> "_chat.db") 1 False
|
||||
Just user <- find activeUser <$> getUsers st
|
||||
startTestChat_ st opts dbFilePrefix user
|
||||
startTestChat_ st cfg opts dbFilePrefix user
|
||||
|
||||
startTestChat_ :: SQLiteStore -> ChatOpts -> FilePath -> User -> IO TestCC
|
||||
startTestChat_ st opts dbFilePrefix user = do
|
||||
startTestChat_ :: SQLiteStore -> ChatConfig -> ChatOpts -> FilePath -> User -> IO TestCC
|
||||
startTestChat_ st cfg opts dbFilePrefix user = do
|
||||
t <- withVirtualTerminal termSettings pure
|
||||
ct <- newChatTerminal t
|
||||
cc <- newChatController st (Just user) cfg opts {dbFilePrefix} Nothing -- no notifications
|
||||
@@ -114,16 +127,34 @@ stopTestChat TestCC {chatController = cc, chatAsync, termAsync} = do
|
||||
uninterruptibleCancel chatAsync
|
||||
|
||||
withNewTestChat :: String -> Profile -> (TestCC -> IO a) -> IO a
|
||||
withNewTestChat = withNewTestChatOpts testOpts
|
||||
withNewTestChat = withNewTestChatCfgOpts testCfg testOpts
|
||||
|
||||
withNewTestChatV1 :: String -> Profile -> (TestCC -> IO a) -> IO a
|
||||
withNewTestChatV1 = withNewTestChatCfg testCfgV1
|
||||
|
||||
withNewTestChatCfg :: ChatConfig -> String -> Profile -> (TestCC -> IO a) -> IO a
|
||||
withNewTestChatCfg cfg = withNewTestChatCfgOpts cfg testOpts
|
||||
|
||||
withNewTestChatOpts :: ChatOpts -> String -> Profile -> (TestCC -> IO a) -> IO a
|
||||
withNewTestChatOpts opts dbPrefix profile = bracket (createTestChat opts dbPrefix profile) (\cc -> cc <// 100000 >> stopTestChat cc)
|
||||
withNewTestChatOpts = withNewTestChatCfgOpts testCfg
|
||||
|
||||
withNewTestChatCfgOpts :: ChatConfig -> ChatOpts -> String -> Profile -> (TestCC -> IO a) -> IO a
|
||||
withNewTestChatCfgOpts cfg opts dbPrefix profile = bracket (createTestChat cfg opts dbPrefix profile) (\cc -> cc <// 100000 >> stopTestChat cc)
|
||||
|
||||
withTestChatV1 :: String -> (TestCC -> IO a) -> IO a
|
||||
withTestChatV1 = withTestChatCfg testCfgV1
|
||||
|
||||
withTestChat :: String -> (TestCC -> IO a) -> IO a
|
||||
withTestChat = withTestChatOpts testOpts
|
||||
withTestChat = withTestChatCfgOpts testCfg testOpts
|
||||
|
||||
withTestChatCfg :: ChatConfig -> String -> (TestCC -> IO a) -> IO a
|
||||
withTestChatCfg cfg = withTestChatCfgOpts cfg testOpts
|
||||
|
||||
withTestChatOpts :: ChatOpts -> String -> (TestCC -> IO a) -> IO a
|
||||
withTestChatOpts opts dbPrefix = bracket (startTestChat opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
|
||||
withTestChatOpts = withTestChatCfgOpts testCfg
|
||||
|
||||
withTestChatCfgOpts :: ChatConfig -> ChatOpts -> String -> (TestCC -> IO a) -> IO a
|
||||
withTestChatCfgOpts cfg opts dbPrefix = bracket (startTestChat cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
|
||||
|
||||
readTerminalOutput :: VirtualTerminal -> TQueue String -> IO ()
|
||||
readTerminalOutput t termQ = do
|
||||
@@ -154,8 +185,8 @@ withTmpFiles =
|
||||
(createDirectoryIfMissing False "tests/tmp")
|
||||
(removePathForcibly "tests/tmp")
|
||||
|
||||
testChatN :: ChatOpts -> [Profile] -> ([TestCC] -> IO ()) -> IO ()
|
||||
testChatN opts ps test = withTmpFiles $ do
|
||||
testChatN :: ChatConfig -> ChatOpts -> [Profile] -> ([TestCC] -> IO ()) -> IO ()
|
||||
testChatN cfg opts ps test = withTmpFiles $ do
|
||||
tcs <- getTestCCs (zip ps [1 ..]) []
|
||||
test tcs
|
||||
concurrentlyN_ $ map (<// 100000) tcs
|
||||
@@ -163,7 +194,7 @@ testChatN opts ps test = withTmpFiles $ do
|
||||
where
|
||||
getTestCCs :: [(Profile, Int)] -> [TestCC] -> IO [TestCC]
|
||||
getTestCCs [] tcs = pure tcs
|
||||
getTestCCs ((p, db) : envs') tcs = (:) <$> createTestChat opts (show db) p <*> getTestCCs envs' tcs
|
||||
getTestCCs ((p, db) : envs') tcs = (:) <$> createTestChat cfg opts (show db) p <*> getTestCCs envs' tcs
|
||||
|
||||
(<//) :: TestCC -> Int -> Expectation
|
||||
(<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing
|
||||
@@ -183,24 +214,36 @@ userName :: TestCC -> IO [Char]
|
||||
userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser
|
||||
|
||||
testChat2 :: Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat2 = testChatOpts2 testOpts
|
||||
testChat2 = testChatCfgOpts2 testCfg testOpts
|
||||
|
||||
testChatCfg2 :: ChatConfig -> Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChatCfg2 cfg = testChatCfgOpts2 cfg testOpts
|
||||
|
||||
testChatOpts2 :: ChatOpts -> Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChatOpts2 opts p1 p2 test = testChatN opts [p1, p2] test_
|
||||
testChatOpts2 = testChatCfgOpts2 testCfg
|
||||
|
||||
testChatCfgOpts2 :: ChatConfig -> ChatOpts -> Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChatCfgOpts2 cfg opts p1 p2 test = testChatN cfg opts [p1, p2] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2] = test tc1 tc2
|
||||
test_ _ = error "expected 2 chat clients"
|
||||
|
||||
testChat3 :: Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat3 p1 p2 p3 test = testChatN testOpts [p1, p2, p3] test_
|
||||
testChat3 = testChatCfgOpts3 testCfg testOpts
|
||||
|
||||
testChatCfg3 :: ChatConfig -> Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChatCfg3 cfg = testChatCfgOpts3 cfg testOpts
|
||||
|
||||
testChatCfgOpts3 :: ChatConfig -> ChatOpts -> Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChatCfgOpts3 cfg opts p1 p2 p3 test = testChatN cfg opts [p1, p2, p3] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2, tc3] = test tc1 tc2 tc3
|
||||
test_ _ = error "expected 3 chat clients"
|
||||
|
||||
testChat4 :: Profile -> Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
|
||||
testChat4 p1 p2 p3 p4 test = testChatN testOpts [p1, p2, p3, p4] test_
|
||||
testChat4 p1 p2 p3 p4 test = testChatN testCfg testOpts [p1, p2, p3, p4] test_
|
||||
where
|
||||
test_ :: [TestCC] -> IO ()
|
||||
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4
|
||||
@@ -226,7 +269,8 @@ serverCfg =
|
||||
privateKeyFile = "tests/fixtures/tls/server.key",
|
||||
certificateFile = "tests/fixtures/tls/server.crt",
|
||||
logStatsInterval = Just 86400,
|
||||
logStatsStartTime = 0
|
||||
logStatsStartTime = 0,
|
||||
smpServerVRange = supportedSMPServerVRange
|
||||
}
|
||||
|
||||
withSmpServer :: IO a -> IO a
|
||||
|
||||
Reference in New Issue
Block a user