From d44f09d1112f2de6eaacd83268a7abe17efd11b7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 12 Mar 2025 21:47:44 +0000 Subject: [PATCH] tests: pass AStoreType to agent test as a parameter (#1479) * tests: run agent tests with PostgreSQL SMP servers * agent tests with postgres database * enable tests * fix store log tests * fix test --- src/Simplex/Messaging/Agent/Store/Postgres.hs | 2 +- src/Simplex/Messaging/Server/StoreLog.hs | 1 - tests/AgentTests.hs | 9 +- tests/AgentTests/FunctionalAPITests.hs | 572 +++++++++--------- tests/AgentTests/MigrationTests.hs | 5 +- tests/AgentTests/NotificationTests.hs | 82 +-- tests/SMPClient.hs | 83 +-- tests/SMPProxyTests.hs | 50 +- tests/ServerTests.hs | 110 ++-- tests/Test.hs | 19 +- tests/Util.hs | 9 + 11 files changed, 485 insertions(+), 457 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 3f5c14b26..50494e781 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -113,7 +113,7 @@ doesSchemaExist db schema = do closeDBStore :: DBStore -> IO () closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} = ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do - replicateM_ dbPoolSize $ atomically $ readTBQueue dbPool + replicateM_ dbPoolSize $ atomically (readTBQueue dbPool) >>= DB.close atomically $ writeTVar dbClosed True reopenDBStore :: DBStore -> IO () diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index df144c7e9..d82062ec3 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -40,7 +40,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (sort, stripPrefix) -import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 1c0a69d8d..a9a64e5c7 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -14,6 +14,7 @@ import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) import AgentTests.NotificationTests (notificationTests) import AgentTests.ServerChoice (serverChoiceTests) +import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec #if defined(dbPostgres) @@ -23,8 +24,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) import AgentTests.SQLiteTests (storeTests) #endif -agentTests :: ATransport -> Spec -agentTests (ATransport t) = do +agentTests :: (ATransport, AStoreType) -> Spec +agentTests ps = do describe "Migration tests" migrationTests describe "Connection request" connectionRequestTests describe "Double ratchet tests" doubleRatchetTests @@ -33,9 +34,9 @@ agentTests (ATransport t) = do #else do #endif - describe "Functional API" $ functionalAPITests (ATransport t) + describe "Functional API" $ functionalAPITests ps describe "Chosen servers" serverChoiceTests - describe "Notification tests" $ notificationTests (ATransport t) + describe "Notification tests" $ notificationTests ps #if !defined(dbPostgres) describe "SQLite store" storeTests #endif diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 97ced934e..cbe1c47bc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -77,7 +77,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, cfgJ2, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -96,7 +96,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo @@ -263,218 +263,218 @@ sendMessage c connId msgFlags msgBody = do liftIO $ pqEnc `shouldBe` PQEncOn pure msgId -functionalAPITests :: ATransport -> Spec -functionalAPITests t = do +functionalAPITests :: (ATransport, AStoreType) -> Spec +functionalAPITests ps = do describe "Establishing duplex connection" $ do - testMatrix2 t runAgentClientTest + testMatrix2 ps runAgentClientTest it "should connect when server with multiple identities is stored" $ - withSmpServer t testServerMultipleIdentities + withSmpServer ps testServerMultipleIdentities it "should connect with two peers" $ - withSmpServer t testAgentClient3 + withSmpServer ps testAgentClient3 it "should establish connection without PQ encryption and enable it" $ - withSmpServer t testEnablePQEncryption + withSmpServer ps testEnablePQEncryption describe "Duplex connection - delivery stress test" $ do - describe "one way (50)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 50 - xdescribe "one way (1000)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 1000 - describe "two way concurrently (50)" $ testMatrix2Stress t $ runAgentClientStressTestConc 25 - xdescribe "two way concurrently (1000)" $ testMatrix2Stress t $ runAgentClientStressTestConc 500 + describe "one way (50)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 50 + xdescribe "one way (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 1000 + describe "two way concurrently (50)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 25 + xdescribe "two way concurrently (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 500 describe "Establishing duplex connection, different PQ settings" $ do - testPQMatrix2 t $ runAgentClientTestPQ False True + testPQMatrix2 ps $ runAgentClientTestPQ False True describe "Establishing duplex connection v2, different Ratchet versions" $ - testRatchetMatrix2 t runAgentClientTest + testRatchetMatrix2 ps runAgentClientTest describe "Establish duplex connection via contact address" $ - testMatrix2 t runAgentClientContactTest + testMatrix2 ps runAgentClientContactTest describe "Establish duplex connection via contact address, different PQ settings" $ do - testPQMatrix2NoInv t $ runAgentClientContactTestPQ False True PQSupportOn + testPQMatrix2NoInv ps $ runAgentClientContactTestPQ False True PQSupportOn describe "Establish duplex connection via contact address v2, different Ratchet versions" $ - testRatchetMatrix2 t runAgentClientContactTest + testRatchetMatrix2 ps runAgentClientContactTest describe "Establish duplex connection via contact address, different PQ settings" $ do - testPQMatrix3 t $ runAgentClientContactTestPQ3 True + testPQMatrix3 ps $ runAgentClientContactTestPQ3 True it "should support rejecting contact request" $ - withSmpServer t testRejectContactRequest + withSmpServer ps testRejectContactRequest describe "Changing connection user id" $ do it "should change user id for new connections" $ do - withSmpServer t testUpdateConnectionUserId + withSmpServer ps testUpdateConnectionUserId describe "Establishing connection asynchronously" $ do it "should connect with initiating client going offline" $ - withSmpServer t testAsyncInitiatingOffline + withSmpServer ps testAsyncInitiatingOffline it "should connect with joining client going offline before its queue activation" $ - withSmpServer t testAsyncJoiningOfflineBeforeActivation + withSmpServer ps testAsyncJoiningOfflineBeforeActivation it "should connect with both clients going offline" $ - withSmpServer t testAsyncBothOffline + withSmpServer ps testAsyncBothOffline it "should connect on the second attempt if server was offline" $ - testAsyncServerOffline t + testAsyncServerOffline ps it "should restore confirmation after client restart" $ - testAllowConnectionClientRestart t + testAllowConnectionClientRestart ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do - it "should increase if compatible, shouldn't decrease" $ - testIncreaseConnAgentVersion t + it "should increase if compatible, shouldn'ps decrease" $ + testIncreaseConnAgentVersion ps it "should increase to max compatible version" $ - testIncreaseConnAgentVersionMaxCompatible t + testIncreaseConnAgentVersionMaxCompatible ps it "should increase when connection was negotiated on different versions" $ - testIncreaseConnAgentVersionStartDifferentVersion t + testIncreaseConnAgentVersionStartDifferentVersion ps -- TODO PQ tests for upgrading connection to PQ encryption it "should deliver message after client restart" $ - testDeliverClientRestart t + testDeliverClientRestart ps it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $ - testDuplicateMessage t + testDuplicateMessage ps it "should report error via msg integrity on skipped messages" $ - testSkippedMessages t + testSkippedMessages ps it "should connect to the server when server goes up if it initially was down" $ - testDeliveryAfterSubscriptionError t + testDeliveryAfterSubscriptionError ps it "should deliver messages if one of connections has quota exceeded" $ - testMsgDeliveryQuotaExceeded t + testMsgDeliveryQuotaExceeded ps describe "message expiration" $ do - it "should expire one message" $ testExpireMessage t - it "should expire multiple messages" $ testExpireManyMessages t - it "should expire one message if quota is exceeded" $ testExpireMessageQuota t - it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota t + it "should expire one message" $ testExpireMessage ps + it "should expire multiple messages" $ testExpireManyMessages ps + it "should expire one message if quota is exceeded" $ testExpireMessageQuota ps + it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota ps #if !defined(dbPostgres) -- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite) describe "Ratchet synchronization" $ do it "should report ratchet de-synchronization, synchronize ratchets" $ - testRatchetSync t + testRatchetSync ps it "should synchronize ratchets after server being offline" $ - testRatchetSyncServerOffline t + testRatchetSyncServerOffline ps it "should synchronize ratchets after client restart" $ - testRatchetSyncClientRestart t + testRatchetSyncClientRestart ps it "should synchronize ratchets after suspend/foreground" $ - testRatchetSyncSuspendForeground t + testRatchetSyncSuspendForeground ps it "should synchronize ratchets when clients start synchronization simultaneously" $ - testRatchetSyncSimultaneous t + testRatchetSyncSimultaneous ps #endif describe "Subscription mode OnlyCreate" $ do it "messages delivered only when polled (v8 - slow handshake)" $ - withSmpServer t testOnlyCreatePullSlowHandshake + withSmpServer ps testOnlyCreatePullSlowHandshake it "messages delivered only when polled" $ - withSmpServer t testOnlyCreatePull + withSmpServer ps testOnlyCreatePull describe "Inactive client disconnection" $ do it "should disconnect clients without subs if they were inactive longer than TTL" $ - testInactiveNoSubs t + testInactiveNoSubs ps it "should NOT disconnect inactive clients when they have subscriptions" $ - testInactiveWithSubs t + testInactiveWithSubs ps it "should NOT disconnect active clients" $ - testActiveClientNotDisconnected t + testActiveClientNotDisconnected ps describe "Suspending agent" $ do it "should update client when agent is suspended" $ - withSmpServer t testSuspendingAgent + withSmpServer ps testSuspendingAgent it "should complete sending messages when agent is suspended" $ - testSuspendingAgentCompleteSending t + testSuspendingAgentCompleteSending ps it "should suspend agent on timeout, even if pending messages not sent" $ - testSuspendingAgentTimeout t + testSuspendingAgentTimeout ps describe "Batching SMP commands" $ do -- disable this and enable the following test to run tests with coverage it "should subscribe to multiple (200) subscriptions with batching" $ - testBatchedSubscriptions 200 10 t + testBatchedSubscriptions 200 10 ps skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $ it "should subscribe to multiple (6) subscriptions with batching" $ - testBatchedSubscriptions 6 3 t + testBatchedSubscriptions 6 3 ps it "should subscribe to multiple connections with pending messages" $ - withSmpServer t $ + withSmpServer ps $ testBatchedPendingMessages 10 5 describe "Batch send messages" $ do - it "should send multiple messages to the same connection" $ withSmpServer t testSendMessagesB - it "should send messages to the 2 connections" $ withSmpServer t testSendMessagesB2 + it "should send multiple messages to the same connection" $ withSmpServer ps testSendMessagesB + it "should send messages to the 2 connections" $ withSmpServer ps testSendMessagesB2 describe "Async agent commands" $ do describe "connect using async agent commands" $ - testBasicMatrix2 t testAsyncCommands + testBasicMatrix2 ps testAsyncCommands it "should restore and complete async commands on restart" $ - testAsyncCommandsRestore t + testAsyncCommandsRestore ps describe "accept connection using async command" $ - testBasicMatrix2 t testAcceptContactAsync + testBasicMatrix2 ps testAcceptContactAsync it "should delete connections using async command when server connection fails" $ - testDeleteConnectionAsync t + testDeleteConnectionAsync ps it "join connection when reply queue creation fails (v8 - slow handshake)" $ - testJoinConnectionAsyncReplyErrorV8 t + testJoinConnectionAsyncReplyErrorV8 ps it "join connection when reply queue creation fails" $ - testJoinConnectionAsyncReplyError t + testJoinConnectionAsyncReplyError ps describe "delete connection waiting for delivery" $ do it "should delete connection immediately if there are no pending messages" $ - testWaitDeliveryNoPending t + testWaitDeliveryNoPending ps it "should delete connection after waiting for delivery to complete" $ - testWaitDelivery t - it "should delete connection if message can't be delivered due to AUTH error" $ - testWaitDeliveryAUTHErr t - it "should delete connection by timeout even if message wasn't delivered" $ - testWaitDeliveryTimeout t + testWaitDelivery ps + it "should delete connection if message can'ps be delivered due to AUTH error" $ + testWaitDeliveryAUTHErr ps + it "should delete connection by timeout even if message wasn'ps delivered" $ + testWaitDeliveryTimeout ps it "should delete connection by timeout, message in progress can be delivered" $ - testWaitDeliveryTimeout2 t + testWaitDeliveryTimeout2 ps describe "Users" $ do it "should create and delete user with connections" $ - withSmpServer t testUsers + withSmpServer ps testUsers it "should create and delete user without connections" $ - withSmpServer t testDeleteUserQuietly + withSmpServer ps testDeleteUserQuietly it "should create and delete user with connections when server connection fails" $ - testUsersNoServer t + testUsersNoServer ps it "should connect two users and switch session mode" $ - withSmpServer t testTwoUsers + withSmpServer ps testTwoUsers describe "Connection switch" $ do describe "should switch delivery to the new queue" $ - testServerMatrix2 t testSwitchConnection + testServerMatrix2 ps testSwitchConnection describe "should switch to new queue asynchronously" $ - testServerMatrix2 t testSwitchAsync + testServerMatrix2 ps testSwitchAsync describe "should delete connection during switch" $ - testServerMatrix2 t testSwitchDelete + testServerMatrix2 ps testSwitchDelete describe "should abort switch in Started phase" $ - testServerMatrix2 t testAbortSwitchStarted + testServerMatrix2 ps testAbortSwitchStarted describe "should abort switch in Started phase, reinitiate immediately" $ - testServerMatrix2 t testAbortSwitchStartedReinitiate + testServerMatrix2 ps testAbortSwitchStartedReinitiate describe "should prohibit to abort switch in Secured phase" $ - testServerMatrix2 t testCannotAbortSwitchSecured + testServerMatrix2 ps testCannotAbortSwitchSecured describe "should switch two connections simultaneously" $ - testServerMatrix2 t testSwitch2Connections + testServerMatrix2 ps testSwitch2Connections describe "should switch two connections simultaneously, abort one" $ - testServerMatrix2 t testSwitch2ConnectionsAbort1 + testServerMatrix2 ps testSwitch2ConnectionsAbort1 describe "SMP basic auth" $ do forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 sqSecured = if v >= sndAuthKeySMPVersion then True else False describe ("v" <> show v <> ": with server auth") $ do -- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail - it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1 - it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1 + it "success " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "disabled " $ testBasicAuth ps False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "NEW fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "NEW fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "JOIN fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1 + it "JOIN fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do - it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2 - it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0 - it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2 - it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "success " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2 + it "srv disabled" $ testBasicAuth ps False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0 + it "auth fst " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2 + it "auth snd " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "auth both " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do - it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing + it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing let srv1 = testSMPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do - testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) + testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testSMPServer2 authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH) - it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing - it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr - it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr + it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Nothing + it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` authErr + it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` authErr describe "getRatchetAdHash" $ it "should return the same data for both peers" $ - withSmpServer t testRatchetAdHash + withSmpServer ps testRatchetAdHash describe "Delivery receipts" $ do - it "should send and receive delivery receipt" $ withSmpServer t testDeliveryReceipts - it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion t - it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t + it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts + it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion ps + it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps describe "user network info" $ do it "should wait for user network" testWaitForUserNetwork it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline it "should resume multiple threads" testResumeMultipleThreads describe "SMP queue info" $ do it "server should respond with queue and subscription information" $ - withSmpServer t testServerQueueInfo + withSmpServer ps testServerQueueInfo -testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int -testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do - let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} +testBasicAuth :: (ATransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int +testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do + let testCfg = (cfgMS msType) {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 expected @@ -489,57 +489,57 @@ canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, Ver canCreateQueue allowNew (srvAuth, _) (clntAuth, _) = allowNew && (isNothing srvAuth || srvAuth == clntAuth) -testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testMatrix2 t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False +testMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2 ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False -testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testMatrix2Stress t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False +testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False + it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False where aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval} aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval} -testBasicMatrix2 :: HasCallStack => ATransport -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testBasicMatrix2 t runTest = do - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest True - it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False - it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False - it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False +testBasicMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testBasicMatrix2 ps runTest = do + it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False -testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testRatchetMatrix2 t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False - it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False - it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False - it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False +testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testRatchetMatrix2 ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "ratchet current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False + it "ratchet prev" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False + it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False + it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False -testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec -testServerMatrix2 t runTest = do - it "1 server" $ withSmpServer t $ runTest initAgentServers - it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> runTest initAgentServers2 +testServerMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec +testServerMatrix2 ps@(t, ASType qs _ms) runTest = do + it "1 server" $ withSmpServer ps $ runTest initAgentServers + it "2 servers" $ withSmpServer ps $ withSmpServerConfigOn t (cfgJ2QS qs) testPort2 $ \_ -> runTest initAgentServers2 -testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True -testPQMatrix2NoInv :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2NoInv :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2NoInv = pqMatrix2_ False -pqMatrix2_ :: HasCallStack => Bool -> ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec -pqMatrix2_ pqInv t test = do +pqMatrix2_ :: HasCallStack => Bool -> (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +pqMatrix2_ pqInv ps test = do it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff) it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn) it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff) @@ -548,14 +548,14 @@ pqMatrix2_ pqInv t test = do it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) where - runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 + runTest = withSmpServerProxy ps . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 testPQMatrix3 :: HasCallStack => - ATransport -> + (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec -testPQMatrix3 t test = do +testPQMatrix3 ps test = do it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff) it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn) it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff) @@ -566,7 +566,7 @@ testPQMatrix3 t test = do it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn) where runTest test' = - withSmpServerProxy t $ + withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId servers = initAgentServersProxy SPMAlways SPFProhibit @@ -1009,10 +1009,10 @@ testAsyncBothOffline = do liftIO $ disposeAgentClient alice' liftIO $ disposeAgentClient bob' -testAsyncServerOffline :: HasCallStack => ATransport -> IO () -testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do +testAsyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO () +testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do -- create connection and shutdown the server - (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ -> + (bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe -- connection fails Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -1020,7 +1020,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do srv `shouldBe` testSMPServer conns `shouldBe` [bobId] -- connection succeeds after server start - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do ("", "", UP srv1 conns1) <- nGet alice liftIO $ do srv1 `shouldBe` testSMPServer @@ -1034,14 +1034,14 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do get bob ##> ("", aliceId, CON) exchangeGreetings alice bobId bob aliceId -testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO () -testAllowConnectionClientRestart t = do +testAllowConnectionClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testAllowConnectionClientRestart ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do (aliceId, bobId, confId) <- - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do runRight $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -1063,7 +1063,7 @@ testAllowConnectionClientRestart t = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB runRight_ $ subscribeConnection alice2 bobId threadDelay 500000 - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do runRight $ do ("", "", UP _ _) <- nGet bob get alice2 ##> ("", bobId, CON) @@ -1073,11 +1073,11 @@ testAllowConnectionClientRestart t = do disposeAgentClient alice2 disposeAgentClient bob -testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersion t = do +testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1138,11 +1138,11 @@ checkVersion c connId v = do ConnectionStats {connAgentVersion} <- getConnectionServers c connId liftIO $ connAgentVersion `shouldBe` VersionSMPA v -testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersionMaxCompatible t = do +testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersionMaxCompatible ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1168,11 +1168,11 @@ testIncreaseConnAgentVersionMaxCompatible t = do disposeAgentClient alice2 disposeAgentClient bob2 -testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersionStartDifferentVersion t = do +testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersionStartDifferentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1194,12 +1194,12 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do disposeAgentClient alice2 disposeAgentClient bob -testDeliverClientRestart :: HasCallStack => ATransport -> IO () -testDeliverClientRestart t = do +testDeliverClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliverClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do + (aliceId, bobId) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight $ do (aliceId, bobId) <- makeConnection alice bob exchangeGreetings alice bobId bob aliceId @@ -1214,7 +1214,7 @@ testDeliverClientRestart t = do bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do ("", "", UP _ _) <- nGet alice @@ -1225,11 +1225,11 @@ testDeliverClientRestart t = do disposeAgentClient alice disposeAgentClient bob2 -testDuplicateMessage :: HasCallStack => ATransport -> IO () -testDuplicateMessage t = do +testDuplicateMessage :: HasCallStack => (ATransport, AStoreType) -> IO () +testDuplicateMessage ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do + (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" @@ -1264,7 +1264,7 @@ testDuplicateMessage t = do alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId @@ -1277,8 +1277,8 @@ testDuplicateMessage t = do disposeAgentClient alice2 disposeAgentClient bob2 -testSkippedMessages :: HasCallStack => ATransport -> IO () -testSkippedMessages t = do +testSkippedMessages :: HasCallStack => (ATransport, AStoreType) -> IO () +testSkippedMessages (t, msType) = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do @@ -1326,12 +1326,12 @@ testSkippedMessages t = do disposeAgentClient alice2 disposeAgentClient bob2 where - cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} + cfg' = (cfgMS msType) {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} -testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO () -testDeliveryAfterSubscriptionError t = do +testDeliveryAfterSubscriptionError :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryAfterSubscriptionError ps = do (aId, bId) <- withAgentClients2 $ \a b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" @@ -1341,14 +1341,14 @@ testDeliveryAfterSubscriptionError t = do withAgentClients2 $ \a b -> do Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId - withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False ackMessage b aId 2 Nothing -testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO () -testMsgDeliveryQuotaExceeded t = - withAgentClients2 $ \a b -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do +testMsgDeliveryQuotaExceeded :: HasCallStack => (ATransport, AStoreType) -> IO () +testMsgDeliveryQuotaExceeded ps = + withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aId, bId) <- makeConnection a b (aId', bId') <- makeConnection a b forM_ ([1 .. 4] :: [Int]) $ \i -> do @@ -1374,27 +1374,27 @@ testMsgDeliveryQuotaExceeded t = get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") -testExpireMessage :: HasCallStack => ATransport -> IO () -testExpireMessage t = +testExpireMessage :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireMessage ps = withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" threadDelay 1500000 3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False ackMessage b aId 2 Nothing -testExpireManyMessages :: HasCallStack => ATransport -> IO () -testExpireManyMessages t = +testExpireManyMessages :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireManyMessages ps = withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b runRight_ $ do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False @@ -1415,7 +1415,7 @@ testExpireManyMessages t = ("", c, MERRS [3, 4] (BROKER _ e)) -> liftIO $ expected c e `shouldBe` True r -> error $ show r - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False ackMessage b aId 2 Nothing @@ -1429,8 +1429,8 @@ withUP a bId p = \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False ] -testExpireMessageQuota :: HasCallStack => ATransport -> IO () -testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do +testExpireMessageQuota :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -1455,8 +1455,8 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJo ackMessage b' aId 4 Nothing disposeAgentClient a -testExpireManyMessagesQuota :: ATransport -> IO () -testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do +testExpireManyMessagesQuota :: (ATransport, AStoreType) -> IO () +testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -1492,9 +1492,9 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, ackMessage b' aId 4 Nothing disposeAgentClient a -testRatchetSync :: HasCallStack => ATransport -> IO () -testRatchetSync t = withAgentClients2 $ \alice bob -> - withSmpServerStoreMsgLogOn t testPort $ \_ -> do +testRatchetSync :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSync ps = withAgentClients2 $ \alice bob -> + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob runRight $ do ConnectionStats {ratchetSyncState} <- synchronizeRatchet bob2 aliceId PQSupportOn False @@ -1566,9 +1566,9 @@ ratchetSyncP' cId rss = \case cId' == cId && rss' == rss && ratchetSyncState == rss _ -> False -testRatchetSyncServerOffline :: HasCallStack => ATransport -> IO () -testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> +testRatchetSyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1577,7 +1577,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False liftIO $ ratchetSyncState `shouldBe` RSStarted - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1592,11 +1592,11 @@ serverUpP = \case ("", "", AEvt SAENone (UP _ _)) -> True _ -> False -testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO () -testRatchetSyncClientRestart t = do +testRatchetSyncClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob2 @@ -1604,7 +1604,7 @@ testRatchetSyncClientRestart t = do ratchetSyncState `shouldBe` RSStarted disposeAgentClient bob2 bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do ("", "", UP _ _) <- nGet alice subscribeConnection bob3 aliceId @@ -1617,11 +1617,11 @@ testRatchetSyncClientRestart t = do disposeAgentClient bob disposeAgentClient bob3 -testRatchetSyncSuspendForeground :: HasCallStack => ATransport -> IO () -testRatchetSyncSuspendForeground t = do +testRatchetSyncSuspendForeground :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncSuspendForeground ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1634,7 +1634,7 @@ testRatchetSyncSuspendForeground t = do threadDelay 100000 foregroundAgent bob2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1646,11 +1646,11 @@ testRatchetSyncSuspendForeground t = do disposeAgentClient bob disposeAgentClient bob2 -testRatchetSyncSimultaneous :: HasCallStack => ATransport -> IO () -testRatchetSyncSimultaneous t = do +testRatchetSyncSimultaneous :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncSimultaneous ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1662,7 +1662,7 @@ testRatchetSyncSimultaneous t = do ConnectionStats {ratchetSyncState = aRSS} <- runRight $ synchronizeRatchet alice bobId PQSupportOn True liftIO $ aRSS `shouldBe` RSStarted - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1773,9 +1773,9 @@ makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do get bob ##> ("", aliceId, A.CON pqEnc) pure (aliceId, bobId) -testInactiveNoSubs :: ATransport -> IO () -testInactiveNoSubs t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testInactiveNoSubs :: (ATransport, AStoreType) -> IO () +testInactiveNoSubs (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check @@ -1783,9 +1783,9 @@ testInactiveNoSubs t = do Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) pure () -testInactiveWithSubs :: ATransport -> IO () -testInactiveWithSubs t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testInactiveWithSubs :: (ATransport, AStoreType) -> IO () +testInactiveWithSubs (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -1794,9 +1794,9 @@ testInactiveWithSubs t = do -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing -testActiveClientNotDisconnected :: ATransport -> IO () -testActiveClientNotDisconnected t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testActiveClientNotDisconnected :: (ATransport, AStoreType) -> IO () +testActiveClientNotDisconnected (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do ts <- getSystemTime @@ -1837,9 +1837,9 @@ testSuspendingAgent = liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False -testSuspendingAgentCompleteSending :: ATransport -> IO () -testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do +testSuspendingAgentCompleteSending :: (ATransport, AStoreType) -> IO () +testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b 2 <- sendMessage a bId SMP.noMsgFlags "hello" get a ##> ("", bId, SENT 2) @@ -1853,7 +1853,7 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 liftIO $ suspendAgent b 5000000 - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ @AgentErrorType $ do -- there will be no UP event for b, because re-subscriptions are suspended until the agent is in foreground get b =##> \case ("", c, SENT 3) -> c == aId; _ -> False get b =##> \case ("", c, SENT 4) -> c == aId; _ -> False @@ -1868,9 +1868,9 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False ackMessage a bId 4 Nothing -testSuspendingAgentTimeout :: ATransport -> IO () -testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do - (aId, _) <- withSmpServer t . runRight $ do +testSuspendingAgentTimeout :: (ATransport, AStoreType) -> IO () +testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do + (aId, _) <- withSmpServer ps . runRight $ do (aId, bId) <- makeConnection a b 2 <- sendMessage a bId SMP.noMsgFlags "hello" get a ##> ("", bId, SENT 2) @@ -1887,8 +1887,8 @@ testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do ("", "", SUSPENDED) <- nGet b pure () -testBatchedSubscriptions :: Int -> Int -> ATransport -> IO () -testBatchedSubscriptions nCreate nDel t = +testBatchedSubscriptions :: Int -> Int -> (ATransport, AStoreType) -> IO () +testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do conns <- runServers $ do conns <- replicateM nCreate $ makeConnection_ PQSupportOff True a b @@ -1944,8 +1944,8 @@ testBatchedSubscriptions nCreate nDel t = M.keys r `shouldMatchList` cs runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do - withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> + withSmpServerStoreLogOn ps testPort $ \t1 -> do + res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res @@ -2079,14 +2079,14 @@ testAsyncCommands sqSecured alice bob baseId = where msgId = subtract baseId -testAsyncCommandsRestore :: ATransport -> IO () -testAsyncCommandsRestore t = do +testAsyncCommandsRestore :: (ATransport, AStoreType) -> IO () +testAsyncCommandsRestore ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe liftIO $ noMessages alice "alice doesn't receive INV because server is down" disposeAgentClient alice withAgent 2 agentCfg initAgentServers testDB $ \alice' -> - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do subscribeConnection alice' bobId get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () @@ -2130,10 +2130,10 @@ testAcceptContactAsync sqSecured alice bob baseId = where msgId = subtract baseId -testDeleteConnectionAsync :: ATransport -> IO () -testDeleteConnectionAsync t = +testDeleteConnectionAsync :: (ATransport, AStoreType) -> IO () +testDeleteConnectionAsync ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do - connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe @@ -2146,9 +2146,9 @@ testDeleteConnectionAsync t = get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" -testWaitDeliveryNoPending :: ATransport -> IO () -testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do +testWaitDeliveryNoPending :: (ATransport, AStoreType) -> IO () +testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob -> + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2174,11 +2174,11 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> baseId = 1 msgId = subtract baseId -testWaitDelivery :: ATransport -> IO () -testWaitDelivery t = +testWaitDelivery :: (ATransport, AStoreType) -> IO () +testWaitDelivery ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2203,7 +2203,7 @@ testWaitDelivery t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do get alice ##> ("", bobId, SENT $ baseId + 3) get alice ##> ("", bobId, SENT $ baseId + 4) get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False @@ -2228,11 +2228,11 @@ testWaitDelivery t = baseId = 1 msgId = subtract baseId -testWaitDeliveryAUTHErr :: ATransport -> IO () -testWaitDeliveryAUTHErr t = +testWaitDeliveryAUTHErr :: (ATransport, AStoreType) -> IO () +testWaitDeliveryAUTHErr ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (_aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2260,7 +2260,7 @@ testWaitDeliveryAUTHErr t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False @@ -2271,11 +2271,11 @@ testWaitDeliveryAUTHErr t = baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout :: ATransport -> IO () -testWaitDeliveryTimeout t = +testWaitDeliveryTimeout :: (ATransport, AStoreType) -> IO () +testWaitDeliveryTimeout ps = withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2303,7 +2303,7 @@ testWaitDeliveryTimeout t = liftIO $ threadDelay 100000 - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" @@ -2311,11 +2311,11 @@ testWaitDeliveryTimeout t = baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout2 :: ATransport -> IO () -testWaitDeliveryTimeout2 t = +testWaitDeliveryTimeout2 :: (ATransport, AStoreType) -> IO () +testWaitDeliveryTimeout2 ps = withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2341,7 +2341,7 @@ testWaitDeliveryTimeout2 t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do get alice ##> ("", bobId, SENT $ baseId + 3) -- "message 1" not delivered @@ -2357,12 +2357,12 @@ testWaitDeliveryTimeout2 t = baseId = 1 msgId = subtract baseId -testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyErrorV8 t = do +testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ATransport, AStoreType) -> IO () +testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a liftIO $ bId' `shouldBe` bId @@ -2371,9 +2371,9 @@ testJoinConnectionAsyncReplyErrorV8 t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do pGet a >>= \case ("", "", AEvt _ (UP _ [_])) -> do ("", _, CONF confId _ "bob's connInfo") <- get a @@ -2389,19 +2389,19 @@ testJoinConnectionAsyncReplyErrorV8 t = do liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) exchangeGreetingsMsgId 4 a bId b aId -testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyError t = do +testJoinConnectionAsyncReplyError :: HasCallStack => (ATransport, AStoreType) -> IO () +testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a liftIO $ bId' `shouldBe` bId @@ -2410,8 +2410,8 @@ testJoinConnectionAsyncReplyError t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do + confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do -- both servers need to be online for connection to progress because of SKEY get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False pGet a >>= \case @@ -2430,7 +2430,7 @@ testJoinConnectionAsyncReplyError t = do liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) @@ -2463,9 +2463,9 @@ testDeleteUserQuietly = exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" -testUsersNoServer :: HasCallStack => ATransport -> IO () -testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do - (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do +testUsersNoServer :: HasCallStack => (ATransport, AStoreType) -> IO () +testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do + (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] @@ -2481,7 +2481,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False exchangeGreetingsMsgId 4 a bId b aId @@ -2898,9 +2898,9 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db -testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) -testSMPServerConnectionTest t newQueueBasicAuth srv = - withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do +testSMPServerConnectionTest :: (ATransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) +testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = + withSmpServerConfigOn t (cfgMS msType) {newQueueBasicAuth} testPort2 $ \_ -> do -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 srv @@ -2933,11 +2933,11 @@ testDeliveryReceipts = ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) ackMessage b aId 5 Nothing -testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () -testDeliveryReceiptsVersion t = do +testDeliveryReceiptsVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryReceiptsVersion ps = do a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aId, bId) <- runRight $ do (aId, bId) <- makeConnection_ PQSupportOff False a b checkVersion a bId 3 @@ -2986,9 +2986,9 @@ testDeliveryReceiptsVersion t = do disposeAgentClient a' disposeAgentClient b' -testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO () -testDeliveryReceiptsConcurrent t = - withSmpServerConfigOn t cfg {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do +testDeliveryReceiptsConcurrent :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryReceiptsConcurrent (t, msType) = + withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do withAgentClients2 $ \a b -> do (aId, bId) <- runRight $ makeConnection a b t1 <- liftIO getCurrentTime @@ -3112,7 +3112,7 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do #if defined(dbPostgres) createStore :: String -> IO (Either MigrationError DBStore) -createStore schema = createAgentStore (DBOpts testDBConnstr schema) MCError +createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 1a879eca7..ae90944f4 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -13,6 +13,7 @@ import Simplex.Messaging.Agent.Store.Shared import System.Random (randomIO) import Test.Hspec #if defined(dbPostgres) +import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple (fromOnly) import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropSchema) @@ -206,7 +207,9 @@ createStore randSuffix migrations confirmMigrations = do let dbOpts = DBOpts { connstr = testDBConnstr, - schema = testSchema randSuffix + schema = B.pack $ testSchema randSuffix, + poolSize = 1, + createSchema = True } createDBStore dbOpts migrations confirmMigrations diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 1fb2e83cb..da85d25aa 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgJ2, cfgVPrev, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') +import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -77,7 +77,7 @@ import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..)) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) import Test.Hspec import UnliftIO @@ -87,8 +87,8 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.SQLite.Simple.QQ (sql) #endif -notificationTests :: ATransport -> Spec -notificationTests t = do +notificationTests :: (ATransport, AStoreType) -> Spec +notificationTests ps@(t, _) = do describe "Managing notification tokens" $ do it "should register and verify notification token" $ withAPNSMockServer $ \apns -> @@ -133,61 +133,65 @@ notificationTests t = do testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) describe "Managing notification subscriptions" $ do describe "should create notification subscription for existing connection" $ - testNtfMatrix t testNotificationSubscriptionExistingConnection + testNtfMatrix ps testNotificationSubscriptionExistingConnection describe "should create notification subscription for new connection" $ - testNtfMatrix t testNotificationSubscriptionNewConnection + testNtfMatrix ps testNotificationSubscriptionNewConnection it "should change notifications mode" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServer t $ testChangeNotificationsMode apns it "should change token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServer t $ testChangeToken apns describe "Notifications server store log" $ it "should save and restore tokens and subscriptions" $ withAPNSMockServer $ \apns -> - testNotificationsStoreLog t apns + testNotificationsStoreLog ps apns describe "Notifications after SMP server restart" $ it "should resume subscriptions after SMP server is restarted" $ withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestart t apns + withNtfServer t $ testNotificationsSMPRestart ps apns describe "Notifications after SMP server restart" $ it "should resume batched subscriptions after SMP server is restarted" $ withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns + withNtfServer t $ testNotificationsSMPRestartBatch 100 ps apns describe "should switch notifications to the new queue" $ - testServerMatrix2 t $ \servers -> + testServerMatrix2 ps $ \servers -> withAPNSMockServer $ \apns -> withNtfServer t $ testSwitchNotifications servers apns it "should keep sending notifications for old token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServerOn t ntfTestPort $ testNotificationsOldToken apns it "should update server from new token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> testNotificationsNewToken apns ntf -testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec -testNtfMatrix t runTest = do +testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix ps@(_, msType) runTest = do describe "next and current" $ do - it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest - it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest + it "curr servers; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; curr clients" $ runNtfTestCfg ps 1 cfgVPrev' ntfServerCfgVPrev agentCfg agentCfg runTest -- servers can be upgraded in any order - it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest -- one of two clients can be upgraded - it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest - it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest + where + cfg' = cfgMS msType + cfgVPrev' = cfgVPrev msType -runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () -runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do - withSmpServerConfigOn t smpCfg testPort $ \_ -> +runNtfTestCfg :: HasCallStack => (ATransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do + let smpCfg' = smpCfg {serverStoreCfg = serverStoreConfig msType} + withSmpServerConfigOn t smpCfg' testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ -> withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId @@ -746,9 +750,9 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d baseId = 1 msgId = subtract baseId -testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () -testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do - withSmpServerStoreMsgLogOn t testPort $ \_ -> do +testNotificationsStoreLog :: (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apns @@ -779,13 +783,13 @@ testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do ackMessage alice bobId 4 Nothing noNotifications apns - withSmpServerStoreMsgLogOn t testPort $ \_ -> + withSmpServerStoreMsgLogOn ps testPort $ \_ -> withNtfServerStoreLog t $ \_ -> runRight_ $ do void $ messageNotificationData alice apns -testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do +testNotificationsSMPRestart :: (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apns liftIO $ threadDelay 250000 @@ -801,7 +805,7 @@ testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False - withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \threadId -> runRight_ $ do nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 @@ -811,8 +815,8 @@ testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId -testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestartBatch n t apns = +testNotificationsSMPRestartBatch :: Int -> (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do threadDelay 1000000 conns <- runServers $ do @@ -851,8 +855,8 @@ testNotificationsSMPRestartBatch n t apns = where runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do - withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> + withSmpServerStoreLogOn ps testPort $ \t1 -> do + res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index a1527b78a..653a03b84 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -146,23 +146,24 @@ testSMPClient_ host port vr client = do cfg :: ServerConfig cfg = cfgMS (ASType SQSMemory SMSJournal) --- TODO [postgres] --- cfg :: ServerConfig --- cfg = cfgMS (ASType SQSPostgres SMSJournal) +cfgDB :: ServerConfig +cfgDB = cfgMS (ASType SQSPostgres SMSJournal) cfgJ2 :: ServerConfig cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 --- TODO [postgres] --- cfgJ2 :: ServerConfig --- cfgJ2 = journalCfg cfg testStoreDBOpts2 testStoreMsgsDir2 +cfgJ2QS :: SQSType s -> ServerConfig +cfgJ2QS = \case + SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 + SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 journalCfg :: ServerConfig -> FilePath -> FilePath -> ServerConfig journalCfg cfg' storeLogFile storeMsgsPath = cfg' {serverStoreCfg = ASSCfg SQSMemory SMSJournal SSCMemoryJournal {storeLogFile, storeMsgsPath}} --- TODO [postgres] --- journalCfg :: ServerConfig -> DBOpts -> FilePath -> ServerConfig --- journalCfg cfg' storeDBOpts storeMsgsPath' = cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeDBOpts, storeMsgsPath'}} +journalCfgDB :: ServerConfig -> DBOpts -> FilePath -> ServerConfig +journalCfgDB cfg' dbOpts storeMsgsPath' = + let storeCfg = PostgresStoreCfg {dbOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + in cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath'}} cfgMS :: AStoreType -> ServerConfig cfgMS msType = @@ -175,14 +176,7 @@ cfgMS msType = maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, - serverStoreCfg = case msType of - ASType SQSMemory SMSMemory -> - ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile} - ASType SQSMemory SMSJournal -> - ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir} - ASType SQSPostgres SMSJournal -> - let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} - in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}, + serverStoreCfg = serverStoreConfig msType, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -218,14 +212,24 @@ cfgMS msType = startOptions = StartOptions {maintenance = False, skipWarnings = False, confirmMigrations = MCYesUp} } +serverStoreConfig :: AStoreType -> AServerStoreCfg +serverStoreConfig = \case + ASType SQSMemory SMSMemory -> + ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile} + ASType SQSMemory SMSJournal -> + ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir} + ASType SQSPostgres SMSJournal -> + let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir} + cfgV7 :: ServerConfig cfgV7 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} -cfgV8 :: ServerConfig -cfgV8 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} +cfgV8 :: AStoreType -> ServerConfig +cfgV8 msType = (cfgMS msType) {smpServerVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} -cfgVPrev :: ServerConfig -cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} +cfgVPrev :: AStoreType -> ServerConfig +cfgVPrev msType = (cfgMS msType) {smpServerVRange = prevRange $ smpServerVRange cfg} prevRange :: VersionRange v -> VersionRange v prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} @@ -234,8 +238,11 @@ prevVersion :: Version v -> Version v prevVersion (Version v) = Version (v - 1) proxyCfg :: ServerConfig -proxyCfg = - cfg +proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal) + +proxyCfgMS :: AStoreType -> ServerConfig +proxyCfgMS msType = + (cfgMS msType) { allowSMPProxy = True, smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}} } @@ -252,18 +259,12 @@ proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion -withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` ASType SQSMemory SMSJournal) - -withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOnMS t msType = +withSmpServerStoreMsgLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreMsgLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} -withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` ASType SQSMemory SMSJournal) - -withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} +withSmpServerStoreLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerConfigOn t cfg' port' = @@ -271,8 +272,8 @@ withSmpServerConfigOn t cfg' port' = (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing) (threadDelay 10000) -withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerThreadOn t = withSmpServerConfigOn t cfg +withSmpServerThreadOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a serverBracket process afterProcess f = do @@ -292,14 +293,14 @@ serverBracket process afterProcess f = do Nothing -> error $ "server did not " <> s _ -> pure () -withSmpServerOn :: HasCallStack => ATransport -> ServiceName -> IO a -> IO a -withSmpServerOn t port' = withSmpServerThreadOn t port' . const +withSmpServerOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> IO a -> IO a +withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const -withSmpServer :: HasCallStack => ATransport -> IO a -> IO a -withSmpServer t = withSmpServerOn t testPort +withSmpServer :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServer ps = withSmpServerOn ps testPort -withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a -withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const +withSmpServerProxy :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 04ba953da..4be81aedc 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -38,7 +38,8 @@ import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (SQSType (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version (mkVersionRange) @@ -52,7 +53,7 @@ import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif -smpProxyTests :: Spec +smpProxyTests :: SpecWith AStoreType smpProxyTests = do describe "server configuration" $ do it "refuses proxy handshake unless enabled" testNoProxy @@ -117,8 +118,9 @@ smpProxyTests = do it "without proxy" . oneServer $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do - it "always via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 + it "always via proxy" $ \msType -> twoServers + (agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1) + msType it "both via proxy" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy" . twoServers $ @@ -131,9 +133,9 @@ smpProxyTests = do agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ agentViaProxyVersionError - it "retries sending when destination or proxy relay is offline" $ + it "retries sending when destination or proxy relay is offline" $ \_ -> agentViaProxyRetryOffline - it "retries sending when destination relay session disconnects in proxy" $ + it "retries sending when destination relay session disconnects in proxy" $ \_ -> agentViaProxyRetryNoSession describe "stress test 1k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) @@ -144,16 +146,17 @@ smpProxyTests = do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 where - oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort . const - twoServers = twoServers_ proxyCfg proxyCfg - twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServers_ cfg1 cfg2 runTest = + oneServer test msType = withSmpServerConfigOn (transport @TLS) (proxyCfgMS msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort $ const test + twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType + twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServersMoreConc test msType = twoServers_ (proxyCfgMS msType) {serverClientConcurrency = 128} (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServersNoConc test msType = twoServers_ (proxyCfgMS msType) {serverClientConcurrency = 1} (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServers_ :: ServerConfig -> ServerConfig -> IO () -> AStoreType -> IO () + twoServers_ cfg1 cfg2 runTest (ASType qsType _) = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> - let cfg2' = journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 - -- TODO [postgres] - -- let cfg2' = journalCfg cfg2 testStoreDBOpts2 testStoreMsgsDir2 + let cfg2' = case qsType of + SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 + SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () @@ -427,25 +430,24 @@ agentViaProxyRetryNoSession = do withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} -testNoProxy :: IO () -testNoProxy = do - withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do +testNoProxy :: AStoreType -> IO () +testNoProxy msType = do + withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) -testProxyAuth :: IO () -testProxyAuth = do +testProxyAuth :: AStoreType -> IO () +testProxyAuth msType = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where - proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"} + proxyCfgAuth = (proxyCfgMS msType) {newQueueBasicAuth = Just "correct"} -todo :: IO () -todo = do - fail "TODO" +todo :: AStoreType -> IO () +todo _ = fail "TODO" runExceptT' :: Exception e => ExceptT e IO a -> IO a runExceptT' a = runExceptT a >>= either throwIO pure diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index c0232ec0f..fcf1943ad 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -17,7 +17,7 @@ module ServerTests where import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, throwIO) import Control.Monad import Control.Monad.IO.Class import CoreTests.MsgStoreTests (testJournalStoreCfg) @@ -70,8 +70,8 @@ serverTests = do describe "GET & SUB commands" testGetSubCommands describe "Exceeding queue quota" testExceedQueueQuota describe "Store log" testWithStoreLog - xdescribe "Restore messages" testRestoreMessages -- TODO [postgres] - xdescribe "Restore messages (old / v2)" testRestoreExpireMessages -- TODO [postgres] + describe "Restore messages" testRestoreMessages + describe "Restore messages (old / v2)" testRestoreExpireMessages describe "Save prometheus metrics" testPrometheusMetrics describe "Timing of AUTH error" testTiming describe "Message notifications" testMessageNotifications @@ -564,7 +564,7 @@ testExceedQueueQuota = testWithStoreLog :: SpecWith (ATransport, AStoreType) testWithStoreLog = - xit "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do + it "should store simplex queues to log and restore them after server restart" $ \ps@(at@(ATransport t), _) -> do g <- C.newRandom (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -576,7 +576,7 @@ testWithStoreLog = senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) @@ -607,7 +607,7 @@ testWithStoreLog = Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) pure () - logSize testStoreLogFile `shouldReturn` 6 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 6 let cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory Nothing} withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do @@ -616,7 +616,7 @@ testWithStoreLog = Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello") pure () - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored rId1 <- readTVarIO recipientId1 Just rKey1 <- readTVarIO recipientKey1 @@ -633,8 +633,9 @@ testWithStoreLog = Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") pure () - logSize testStoreLogFile `shouldReturn` 1 - removeFile testStoreLogFile + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + removeFile testStoreLogFile where runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do @@ -644,15 +645,24 @@ testWithStoreLog = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () +usesStoreLog :: (ATransport, AStoreType) -> Bool +usesStoreLog (_, ASType qsType _) = case qsType of + SQSMemory -> True + SQSPostgres -> False + logSize :: FilePath -> IO Int -logSize f = - try (length . B.lines <$> B.readFile f) >>= \case - Right l -> pure l - Left (_ :: SomeException) -> logSize f +logSize f = go (10 :: Int) + where + go n = + try (length . B.lines <$> B.readFile f) >>= \case + Right l -> pure l + Left (e :: SomeException) + | n > 0 -> threadDelay 100000 >> go (n - 1) + | otherwise -> throwIO e testRestoreMessages :: SpecWith (ATransport, AStoreType) testRestoreMessages = - it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do + it "should store messages on exit and restore on start" $ \ps@(ATransport t, _) -> do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir @@ -664,8 +674,7 @@ testRestoreMessages = recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -685,16 +694,12 @@ testRestoreMessages = Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 5") Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6") pure () - rId <- readTVarIO recipientId - - logSize testStoreLogFile `shouldReturn` 2 - -- logSize testStoreMsgsFile `shouldReturn` 5 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 2 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -704,15 +709,14 @@ testRestoreMessages = (dec mId3 msg3, Right "hello 3") #== "restored message delivered" Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3) (dec mId4 msg4, Right "hello 4") #== "restored message delivered" - - logSize testStoreLogFile `shouldReturn` 1 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd -- logSize testStoreMsgsFile `shouldReturn` 3 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -724,13 +728,12 @@ testRestoreMessages = (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered" Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6) pure () - logSize testStoreLogFile `shouldReturn` 1 - -- logSize testStoreMsgsFile `shouldReturn` 0 + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + removeFile testStoreLogFile logSize testServerStatsBackupFile `shouldReturn` 76 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 - - removeFile testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile @@ -761,15 +764,14 @@ checkStats s qs sent received = do testRestoreExpireMessages :: SpecWith (ATransport, AStoreType) testRestoreExpireMessages = - it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do + it "should store messages on exit and restore on start (old / v2)" $ \ps@(at@(ATransport t), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO NoEntity recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -784,31 +786,36 @@ testRestoreExpireMessages = Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3") Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") pure () - - logSize testStoreLogFile `shouldReturn` 2 - exportStoreMessages msType - msgs <- B.readFile testStoreMsgsFile - length (B.lines msgs) `shouldBe` 4 + msgs <- + if usesStoreLog ps + then do + logSize testStoreLogFile `shouldReturn` 2 + exportStoreMessages msType + msgs <- B.readFile testStoreMsgsFile + length (B.lines msgs) `shouldBe` 4 + pure msgs + else pure [] let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 - exportStoreMessages msType - msgs' <- B.readFile testStoreMsgsFile - msgs' `shouldBe` msgs - + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + exportStoreMessages msType + msgs' <- B.readFile testStoreMsgsFile + msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 - -- two messages expired - exportStoreMessages msType - msgs'' <- B.readFile testStoreMsgsFile - length (B.lines msgs'') `shouldBe` 2 - B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + -- two messages expired + exportStoreMessages msType + msgs'' <- B.readFile testStoreMsgsFile + length (B.lines msgs'') `shouldBe` 2 + B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where @@ -822,6 +829,7 @@ testRestoreExpireMessages = readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog removeFileIfExists testStoreMsgsFile exportMessages False ms testStoreMsgsFile False + closeMsgStore ms runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -1020,9 +1028,9 @@ testMsgNOTExpireOnInterval = testBlockMessageQueue :: SpecWith (ATransport, AStoreType) testBlockMessageQueue = -- TODO [postgres] - xit "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do + xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c), _) -> do g <- C.newRandom - (rId, sId) <- withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + (rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True) @@ -1032,7 +1040,7 @@ testBlockMessageQueue = -- TODO [postgres] block via control port withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent - withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub) (sId2, sId) #== "same queue ID in response" diff --git a/tests/Test.hs b/tests/Test.hs index bfcae0e08..c3322b24e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -26,7 +26,6 @@ import RemoteControl (remoteControlTests) import SMPClient (testServerDBConnectInfo) import SMPProxyTests (smpProxyTests) import ServerTests -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport (TLS, Transport (..)) @@ -34,12 +33,12 @@ import Simplex.Messaging.Transport (TLS, Transport (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec +import Util (postgressBracket) import XFTPAgent import XFTPCLI import XFTPServerTests (xftpServerTests) #if defined(dbPostgres) import Fixtures -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #else import AgentTests.SchemaDump (schemaDumpTest) #endif @@ -54,10 +53,8 @@ main = do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" hspec - -- TODO [postgres] run tests with postgres server locally and maybe in CI #if defined(dbPostgres) - . beforeAll_ (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) - . afterAll_ (dropDatabaseAndUser testDBConnectInfo) + . aroundAll_ (postgressBracket testDBConnectInfo) #endif . before_ (createDirectoryIfMissing False "tests/tmp") . after_ (eventuallyRemove "tests/tmp" 3) @@ -78,8 +75,7 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests - beforeAll_ (dropDatabaseAndUser testServerDBConnectInfo >> createDBAndUserIfNotExists testServerDBConnectInfo) - $ afterAll_ (dropDatabaseAndUser testServerDBConnectInfo) + aroundAll_ (postgressBracket testServerDBConnectInfo) -- TODO [postgres] fix store log tests $ describe "SMP server via TLS, postgres+jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) @@ -93,8 +89,13 @@ main = do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) - describe "SMP client agent" $ agentTests (transport @TLS) - describe "SMP proxy" smpProxyTests + aroundAll_ (postgressBracket testServerDBConnectInfo) $ do + describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) + describe "SMP proxy, postgres+jornal message store" $ + before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests + describe "SMP client agent, jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) + describe "SMP proxy, jornal message store" $ + before (pure $ ASType SQSMemory SMSJournal) smpProxyTests describe "XFTP" $ do describe "XFTP server" xftpServerTests describe "XFTP file description" fileDescriptionTests diff --git a/tests/Util.hs b/tests/Util.hs index 0ad371b69..2d2c7b089 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,9 +1,12 @@ module Util where +import qualified Control.Exception as E import Control.Monad (replicateM, when) import Data.Either (partitionEithers) import Data.List (tails) +import Database.PostgreSQL.Simple (ConnectInfo (..)) import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO @@ -32,3 +35,9 @@ removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do fileExists <- doesFileExist filePath when fileExists $ removeFile filePath + +postgressBracket :: ConnectInfo -> IO a -> IO a +postgressBracket connInfo = + E.bracket_ + (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) + (dropDatabaseAndUser connInfo)