From 121944699628bb05e6b4955c8f2f8647e0f77bd7 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 10 Apr 2024 19:34:02 +0100 Subject: [PATCH] dispose agent instances, fix tests, (#1089) * dispose agent instances in tests * fix quota test * tests: fix tests with -threaded (#1088) * fix some tests * match RTS opts with apps * less verbose rts stats * enable sqlite extended error codes * clean up * unfocus * remove extendedErrorCode It's actually setExtendedResultCodes, which isn't yet available. * diff --------- Co-authored-by: Evgeny Poberezkin * fix switch test * fix --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> --- package.yaml | 5 + simplexmq.cabal | 2 +- src/Simplex/Messaging/Agent.hs | 6 +- src/Simplex/Messaging/Agent/Client.hs | 4 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 2 +- tests/AgentTests.hs | 6 +- tests/AgentTests/FunctionalAPITests.hs | 737 ++++++++++---------- tests/AgentTests/NotificationTests.hs | 293 ++++---- tests/SMPClient.hs | 2 +- tests/ServerTests.hs | 2 +- tests/XFTPAgent.hs | 496 ++++++------- tests/XFTPClient.hs | 4 +- 12 files changed, 740 insertions(+), 819 deletions(-) diff --git a/package.yaml b/package.yaml index 3bb260415..60d58be10 100644 --- a/package.yaml +++ b/package.yaml @@ -169,6 +169,11 @@ tests: - silently == 1.2.* - main-tester == 0.2.* - timeit == 2.0.* + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-A64M + - -with-rtsopts=-N1 ghc-options: # - -haddock diff --git a/simplexmq.cabal b/simplexmq.cabal index e2a5c1e10..b85281080 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -661,7 +661,7 @@ test-suite simplexmq-test tests default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1 build-depends: HUnit ==1.6.* , QuickCheck ==2.14.* diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 7330e823f..ffb967e0c 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -2351,10 +2351,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, case L.nonEmpty keepSqs of Just sqs' -> do -- move inside case? - withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo - let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - sq2 <- withStore c $ \db -> addConnSndQueue db connId sq'' + sq2 <- withStore c $ \db -> do + liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs + addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} case (sndPublicKey, e2ePubKey) of (Just sndPubKey, Just dhPublicKey) -> do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 1c1783948..cd68cd158 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -133,7 +133,7 @@ import Control.Applicative ((<|>)) import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Concurrent.Async (Async, uninterruptibleCancel) import Control.Concurrent.STM (retry, throwSTM) -import Control.Exception (AsyncException (..)) +import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..)) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -790,7 +790,7 @@ closeClient c clientSel tSess = closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO () closeClient_ c v = do NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c - tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case + E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case Just (Right client) -> closeProtocolServerClient client `catchAll_` pure () _ -> pure () diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 2f6707c5a..b8b1c7c52 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1214,7 +1214,7 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = db [sql| UPDATE ratchets - SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? + SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? WHERE conn_id = ? |] (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 34719e803..b95229ac1 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -194,8 +194,8 @@ pqMatrix2_ pqInv _ smpTest test = do pqMatrix3 :: HasCallStack => - TProxy c -> - (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> + TProxy c -> + (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) -> Spec pqMatrix3 _ smpTest test = do @@ -452,7 +452,7 @@ testServerConnectionAfterError t _ = do where server = SMPServer "localhost" testPort2 testKeyHash withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` () - withAgent1 = withAgent agentTestPort testDB 0 + withAgent1 = withAgent agentTestPort testDB 0 withAgent2 = withAgent agentTestPort2 testDB2 10 withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 3fa8becdf..28cef8417 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -10,7 +10,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -19,7 +18,11 @@ module AgentTests.FunctionalAPITests ( functionalAPITests, testServerMatrix2, withAgentClientsCfg2, + withAgentClientsCfgServers2, getSMPAgentClient', + withAgent, + withAgentClients2, + withAgentClients3, makeConnection, exchangeGreetingsMsgId, switchComplete, @@ -64,6 +67,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL +import GHC.Stack (withFrozenCallStack) import SMPAgentClient import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) @@ -76,15 +80,15 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteS import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOn, pattern PQEncOff, pattern PQSupportOn, pattern PQSupportOff) +import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF, authBatchCmdsNTFVersion) +import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, 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 (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, batchCmdsSMPVersion, basicAuthSMPVersion, currentServerSMPRelayVersion) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V import Simplex.Messaging.Version.Internal (Version (..)) @@ -101,32 +105,32 @@ type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) (##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () a ##> t = withTimeout a (`shouldBe` t) -(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (a -> Bool) -> m () +(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Bool) -> m () a =##> p = withTimeout a $ \r -> do unless (p r) $ liftIO $ putStrLn $ "value failed predicate: " <> show r r `shouldSatisfy` p -withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (a -> Expectation) -> m () +withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Expectation) -> m () withTimeout a test = timeout 10_000000 a >>= \case Nothing -> error "operation timed out" Just t -> liftIO $ test t -get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn) -get = get' @'AEConn +get :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AEConn) +get c = withFrozenCallStack $ get' @'AEConn c -rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile) -rfGet = get' @'AERcvFile +rfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AERcvFile) +rfGet c = withFrozenCallStack $ get' @'AERcvFile c -sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile) -sfGet = get' @'AESndFile +sfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AESndFile) +sfGet c = withFrozenCallStack $ get' @'AESndFile c -nGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AENone) -nGet = get' @'AENone +nGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AENone) +nGet c = withFrozenCallStack $ get' @'AENone c -get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e) -get' c = do +get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e) +get' c = withFrozenCallStack $ do (corrId, connId, APC e cmd) <- pGet c case testEquality e (sAEntity @e) of Just Refl -> pure (corrId, connId, cmd) @@ -219,11 +223,11 @@ runRight action = Left e -> error $ "Unexpected error: " <> show e getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation -getInAnyOrder c = inAnyOrder (pGet c) +getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m () inAnyOrder _ [] = pure () -inAnyOrder g rs = do +inAnyOrder g rs = withFrozenCallStack $ do r <- g let rest = filter (not . expected r) rs if length rest < length rs @@ -280,7 +284,7 @@ functionalAPITests t = do testIncreaseConnAgentVersionMaxCompatible t it "should increase when connection was negotiated on different versions" $ testIncreaseConnAgentVersionStartDifferentVersion t - -- TODO PQ tests for upgrading connection to PQ encryption + -- TODO PQ tests for upgrading connection to PQ encryption it "should deliver message after client restart" $ testDeliverClientRestart t it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $ @@ -440,7 +444,7 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do - it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn + it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn @@ -451,10 +455,10 @@ testMatrix2 t runTest = do testRatchetMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 t runTest = do - it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn - it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn - it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn + it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn + it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn + it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn + it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff @@ -464,20 +468,30 @@ testServerMatrix2 t runTest = do it "1 server" $ withSmpServer t $ runTest initAgentServers it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2 -runTestCfg2 :: AgentConfig -> AgentConfig -> AgentMsgId -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () +runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTestCfg2 aCfg bCfg baseMsgId runTest = withAgentClientsCfg2 aCfg bCfg $ \a b -> runTest a b baseMsgId +{-# INLINE runTestCfg2 #-} -withAgentClientsCfg2 :: AgentConfig -> AgentConfig -> (AgentClient -> AgentClient -> IO ()) -> IO () -withAgentClientsCfg2 aCfg bCfg runTest = do - a <- getSMPAgentClient' 1 aCfg initAgentServers testDB - b <- getSMPAgentClient' 2 bCfg initAgentServers testDB2 - runTest a b - disposeAgentClient a - disposeAgentClient b +withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfgServers2 aCfg bCfg servers runTest = + withAgent 1 aCfg servers testDB $ \a -> + withAgent 2 bCfg servers testDB2 $ \b -> + runTest a b -withAgentClients2 :: (AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers +{-# INLINE withAgentClientsCfg2 #-} + +withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg +{-# INLINE withAgentClients2 #-} + +withAgentClients3 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClients3 runTest = + withAgentClients2 $ \a b -> + withAgent 3 agentCfg initAgentServers testDB3 $ \c -> + runTest a b c runAgentClientTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientTest pqSupport alice@AgentClient {} bob baseId = @@ -517,11 +531,9 @@ runAgentClientTest pqSupport alice@AgentClient {} bob baseId = msgId = subtract baseId . fst testEnablePQEncryption :: HasCallStack => IO () -testEnablePQEncryption = do - ca <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - cb <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - g <- C.newRandom - runRight_ $ do +testEnablePQEncryption = + withAgentClients2 $ \ca cb -> runRight_ $ do + g <- liftIO C.newRandom (aId, bId) <- makeConnection_ PQSupportOff ca cb let a = (ca, aId) b = (cb, bId) @@ -587,11 +599,8 @@ sndRcv pqEnc pqEnc' ((c1, id1), mId, msg) (c2, id2) = do ackMessage c2 id1 mId Nothing testAgentClient3 :: HasCallStack => IO () -testAgentClient3 = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testAgentClient3 = + withAgentClients3 $ \a b c -> runRight_ $ do (aIdForB, bId) <- makeConnection a b (aIdForC, cId) <- makeConnection a c @@ -662,7 +671,8 @@ noMessages c err = tryGet `shouldReturn` () testAsyncInitiatingOffline :: HasCallStack => IO () testAsyncInitiatingOffline = - withAgentClients2 $ \alice bob -> runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do + alice <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe liftIO $ disposeAgentClient alice aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -674,10 +684,12 @@ testAsyncInitiatingOffline = get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) exchangeGreetings alice' bobId bob aliceId + liftIO $ disposeAgentClient alice' testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO () testAsyncJoiningOfflineBeforeActivation = - withAgentClients2 $ \alice bob -> runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do + bob <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe liftIO $ disposeAgentClient bob @@ -689,10 +701,13 @@ testAsyncJoiningOfflineBeforeActivation = get bob' ##> ("", aliceId, INFO "alice's connInfo") get bob' ##> ("", aliceId, CON) exchangeGreetings alice bobId bob' aliceId + liftIO $ disposeAgentClient bob' testAsyncBothOffline :: HasCallStack => IO () -testAsyncBothOffline = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAsyncBothOffline = do + alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB + bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 + runRight_ $ do (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe liftIO $ disposeAgentClient alice aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -707,6 +722,8 @@ testAsyncBothOffline = get bob' ##> ("", aliceId, INFO "alice's connInfo") get bob' ##> ("", aliceId, CON) exchangeGreetings alice' bobId bob' aliceId + liftIO $ disposeAgentClient alice' + liftIO $ disposeAgentClient bob' testAsyncServerOffline :: HasCallStack => ATransport -> IO () testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do @@ -1017,40 +1034,40 @@ testSkippedMessages t = do disposeAgentClient bob2 testExpireMessage :: HasCallStack => ATransport -> IO () -testExpireMessage t = do - a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" - threadDelay 1000000 - 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False - ackMessage b aId 4 Nothing +testExpireMessage t = + withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" + threadDelay 1000000 + 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire + get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False + ackMessage b aId 4 Nothing testExpireManyMessages :: HasCallStack => ATransport -> IO () -testExpireManyMessages t = do - a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b - runRight_ $ do - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- sendMessage a bId SMP.noMsgFlags "1" - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - liftIO $ threadDelay 1000000 - 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False - ackMessage b aId 4 Nothing +testExpireManyMessages t = + withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + runRight_ $ do + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + 4 <- sendMessage a bId SMP.noMsgFlags "1" + 5 <- sendMessage a bId SMP.noMsgFlags "2" + 6 <- sendMessage a bId SMP.noMsgFlags "3" + liftIO $ threadDelay 1000000 + 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire + get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False + ackMessage b aId 4 Nothing withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () withUP a bId p = @@ -1075,16 +1092,16 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP 6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False pure (aId, bId) - b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False ackMessage b' aId 4 Nothing get a ##> ("", bId, SENT 6) get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False ackMessage b' aId 6 Nothing + disposeAgentClient a -testExpireManyMessagesQuota :: HasCallStack => ATransport -> IO () +testExpireManyMessagesQuota :: ATransport -> IO () testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -1099,16 +1116,24 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} liftIO $ threadDelay 1000000 8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False - get a =##> \case ("", c, MERRS [6, 7] (SMP QUOTA)) -> bId == c; _ -> False + get a >>= \case + ("", c, MERR 6 (SMP QUOTA)) -> do + liftIO $ bId `shouldBe` c + get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [6] (SMP QUOTA)) -> do + liftIO $ bId `shouldBe` c + get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [6, 7] (SMP QUOTA)) -> liftIO $ bId `shouldBe` c + r -> error $ show r pure (aId, bId) - b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False ackMessage b' aId 4 Nothing get a ##> ("", bId, SENT 8) get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False ackMessage b' aId 6 Nothing + disposeAgentClient a testRatchetSync :: HasCallStack => ATransport -> IO () testRatchetSync t = withAgentClients2 $ \alice bob -> @@ -1122,6 +1147,7 @@ testRatchetSync t = withAgentClients2 $ \alice bob -> get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + disposeAgentClient bob2 setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do @@ -1206,6 +1232,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + disposeAgentClient bob2 serverUpP :: ATransmission 'Agent -> Bool serverUpP = \case @@ -1221,8 +1248,8 @@ testRatchetSyncClientRestart t = do ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob2 ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False - liftIO $ ratchetSyncState `shouldBe` RSStarted - liftIO $ disposeAgentClient bob2 + ratchetSyncState `shouldBe` RSStarted + disposeAgentClient bob2 bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do runRight_ $ do @@ -1363,35 +1390,33 @@ makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do testInactiveNoSubs :: ATransport -> IO () testInactiveNoSubs t = do let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check - Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) - Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) - disposeAgentClient alice + 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 + Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) + Just (_, _, APC 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}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe - Nothing <- 800000 `timeout` get alice - liftIO $ threadDelay 1200000 - -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription - liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing - disposeAgentClient alice + withSmpServerConfigOn t cfg' testPort $ \_ -> + withAgent 1 agentCfg initAgentServers testDB $ \alice -> do + runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe + Nothing <- 800000 `timeout` get alice + liftIO $ threadDelay 1200000 + -- 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}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - ts <- getSystemTime - runRight_ $ do - (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe - keepSubscribing alice connId ts - disposeAgentClient alice + withSmpServerConfigOn t cfg' testPort $ \_ -> + withAgent 1 agentCfg initAgentServers testDB $ \alice -> do + ts <- getSystemTime + runRight_ $ do + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + keepSubscribing alice connId ts where keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO () keepSubscribing alice connId ts = do @@ -1476,42 +1501,39 @@ testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do pure () testBatchedSubscriptions :: Int -> Int -> ATransport -> IO () -testBatchedSubscriptions nCreate nDel t = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2 - conns <- runServers $ do - conns <- replicateM (nCreate :: Int) $ makeConnection_ PQSupportOff a b - forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId - let (aIds', bIds') = unzip $ take nDel conns - delete a bIds' - delete b aIds' - liftIO $ threadDelay 1000000 - pure conns - ("", "", DOWN {}) <- nGet a - ("", "", DOWN {}) <- nGet a - ("", "", DOWN {}) <- nGet b - ("", "", DOWN {}) <- nGet b - runServers $ do - ("", "", UP {}) <- nGet a - ("", "", UP {}) <- nGet a - ("", "", UP {}) <- nGet b - ("", "", UP {}) <- nGet b - liftIO $ threadDelay 1000000 - let (aIds, bIds) = unzip conns - conns' = drop nDel conns - (aIds', bIds') = unzip conns' - subscribe a bIds - subscribe b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId - void $ resubscribeConnections a bIds - void $ resubscribeConnections b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId - delete a bIds' - delete b aIds' - deleteFail a bIds' - deleteFail b aIds' - disposeAgentClient a - disposeAgentClient b +testBatchedSubscriptions nCreate nDel t = + withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do + conns <- runServers $ do + conns <- replicateM (nCreate :: Int) $ makeConnection_ PQSupportOff a b + forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId + let (aIds', bIds') = unzip $ take nDel conns + delete a bIds' + delete b aIds' + liftIO $ threadDelay 1000000 + pure conns + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet b + ("", "", DOWN {}) <- nGet b + runServers $ do + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet b + ("", "", UP {}) <- nGet b + liftIO $ threadDelay 1000000 + let (aIds, bIds) = unzip conns + conns' = drop nDel conns + (aIds', bIds') = unzip conns' + subscribe a bIds + subscribe b aIds + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId + void $ resubscribeConnections a bIds + void $ resubscribeConnections b aIds + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId + delete a bIds' + delete b aIds' + deleteFail a bIds' + deleteFail b aIds' where subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () subscribe c cs = do @@ -1597,13 +1619,11 @@ testAsyncCommandsRestore t = do 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 - alice' <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB - withSmpServerStoreLogOn t testPort $ \_ -> do - runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB $ \alice' -> + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do subscribeConnection alice' bobId get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () - disposeAgentClient alice' testAcceptContactAsync :: IO () testAcceptContactAsync = @@ -1645,28 +1665,26 @@ testAcceptContactAsync = msgId = subtract baseId testDeleteConnectionAsync :: ATransport -> IO () -testDeleteConnectionAsync t = do - a <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - connIds <- withSmpServerStoreLogOn t 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 - pure ([bId1, bId2, bId3] :: [ConnId]) - runRight_ $ do - deleteConnectionsAsync a False connIds - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - liftIO $ noMessages a "nothing else should be delivered to alice" - disposeAgentClient a +testDeleteConnectionAsync t = + withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do + connIds <- withSmpServerStoreLogOn t 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 + pure ([bId1, bId2, bId3] :: [ConnId]) + runRight_ $ do + deleteConnectionsAsync a False connIds + nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + liftIO $ noMessages a "nothing else should be delivered to alice" testWaitDeliveryNoPending :: ATransport -> IO () -testWaitDeliveryNoPending t = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do (aliceId, bobId) <- makeConnection alice bob @@ -1689,204 +1707,189 @@ testWaitDeliveryNoPending t = do liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testWaitDelivery :: ATransport -> IO () -testWaitDelivery t = do - alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDelivery t = + 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) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + 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 - get alice ##> ("", bobId, SENT $ baseId + 3) - get alice ##> ("", bobId, SENT $ baseId + 4) - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + get alice ##> ("", bobId, SENT $ baseId + 3) + get alice ##> ("", bobId, SENT $ baseId + 4) + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ - getInAnyOrder - bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False - ] - ackMessage bob aliceId (baseId + 3) Nothing - get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 4) Nothing + liftIO $ + getInAnyOrder + bob + [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + ] + ackMessage bob aliceId (baseId + 3) Nothing + get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 4) Nothing - -- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message - 5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, SENT $ baseId + 5) + -- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message + 5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" + get bob ##> ("", aliceId, SENT $ baseId + 5) - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId testWaitDeliveryAUTHErr :: ATransport -> IO () -testWaitDeliveryAUTHErr t = do - alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryAUTHErr t = + 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) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - deleteConnectionsAsync bob False [aliceId] - get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False - get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False + deleteConnectionsAsync bob False [aliceId] + get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False + get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do - get alice ##> ("", bobId, MERR (baseId + 3) (SMP AUTH)) - get alice ##> ("", bobId, MERR (baseId + 4) (SMP AUTH)) - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> do + get alice ##> ("", bobId, MERR (baseId + 3) (SMP AUTH)) + get alice ##> ("", bobId, MERR (baseId + 4) (SMP AUTH)) + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId testWaitDeliveryTimeout :: ATransport -> IO () -testWaitDeliveryTimeout t = do - alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryTimeout t = + 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) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - liftIO $ threadDelay 100000 + liftIO $ threadDelay 100000 - withSmpServerStoreLogOn t 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" - - disposeAgentClient alice - disposeAgentClient bob + withSmpServerStoreLogOn t 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" where baseId = 3 msgId = subtract baseId testWaitDeliveryTimeout2 :: ATransport -> IO () -testWaitDeliveryTimeout2 t = do - alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryTimeout2 t = + 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) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do - get alice ##> ("", bobId, SENT $ baseId + 3) - -- "message 1" not delivered + withSmpServerStoreLogOn t testPort $ \_ -> do + get alice ##> ("", bobId, SENT $ baseId + 3) + -- "message 1" not delivered - liftIO $ - getInAnyOrder - bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False - ] - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ + getInAnyOrder + bob + [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + ] + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId @@ -1894,43 +1897,41 @@ testWaitDeliveryTimeout2 t = do testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () testJoinConnectionAsyncReplyError t = do let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe - ("1", bId', INV (ACR _ qInfo)) <- get a - liftIO $ bId' `shouldBe` bId - aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe - liftIO $ threadDelay 500000 - ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId - pure (aId, bId) - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerOn t testPort2 $ do - get b =##> \case ("2", c, OK) -> c == aId; _ -> False - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do - pGet a >>= \case - ("", "", APC _ (UP _ [_])) -> do - ("", _, CONF confId _ "bob's connInfo") <- get a - pure confId - ("", _, APC _ (CONF confId _ "bob's connInfo")) -> do - ("", "", UP _ [_]) <- nGet a - pure confId - r -> error $ "unexpected response " <> show r - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - runRight_ $ do - allowConnectionAsync a "3" bId confId "alice's connInfo" - liftIO $ threadDelay 500000 - ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId - pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False - get a ##> ("", bId, CON) - get b ##> ("", aId, INFO "alice's connInfo") - get b ##> ("", aId, CON) - exchangeGreetings a bId b aId - disposeAgentClient a - disposeAgentClient b + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe + ("1", bId', INV (ACR _ qInfo)) <- get a + liftIO $ bId' `shouldBe` bId + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure (aId, bId) + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + withSmpServerOn t testPort2 $ do + get b =##> \case ("2", c, OK) -> c == aId; _ -> False + confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + pGet a >>= \case + ("", "", APC _ (UP _ [_])) -> do + ("", _, CONF confId _ "bob's connInfo") <- get a + pure confId + ("", _, APC _ (CONF confId _ "bob's connInfo")) -> do + ("", "", UP _ [_]) <- nGet a + pure confId + r -> error $ "unexpected response " <> show r + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + runRight_ $ do + allowConnectionAsync a "3" bId confId "alice's connInfo" + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure () + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False + pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testUsers :: IO () testUsers = @@ -1985,16 +1986,12 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} testSwitchConnection :: InitialAgentServers -> IO () -testSwitchConnection servers = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchConnection servers = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId testFullSwitch a bId b aId 10 testFullSwitch a bId b aId 16 - disposeAgentClient a - disposeAgentClient b testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO () testFullSwitch a bId b aId msgId = do @@ -2074,7 +2071,7 @@ testSwitchAsync servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -withAgent :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a +withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) disposeAgentClient sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO () @@ -2087,10 +2084,8 @@ sessionSubscribe withC connIds a = pure r testSwitchDelete :: InitialAgentServers -> IO () -testSwitchDelete servers = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchDelete servers = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId liftIO $ disposeAgentClient b @@ -2102,8 +2097,6 @@ testSwitchDelete servers = do get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" - disposeAgentClient a - disposeAgentClient b testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStarted servers = do @@ -2404,8 +2397,9 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) testSMPServerConnectionTest t newQueueBasicAuth srv = withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running - testProtocolServer a 1 srv + -- initially passed server is not running + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 srv testRatchetAdHash :: HasCallStack => IO () testRatchetAdHash = @@ -2629,6 +2623,7 @@ testServerMultipleIdentities = getSMPAgentClient' 3 agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId exchangeGreetingsMsgId 6 alice bobId bob' aliceId + liftIO $ disposeAgentClient bob' where secondIdentityCReq :: ConnectionRequestUri 'CMInvitation secondIdentityCReq = diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 72bebd569..2c1045791 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -17,7 +17,10 @@ import AgentTests.FunctionalAPITests createConnection, exchangeGreetingsMsgId, get, - getSMPAgentClient', + withAgent, + withAgentClients2, + withAgentClientsCfgServers2, + withAgentClients3, joinConnection, makeConnection, nGet, @@ -47,7 +50,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) import NtfClient -import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2) +import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') @@ -165,8 +168,7 @@ runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = testNotificationToken :: APNSMockServer -> IO () testNotificationToken APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -179,7 +181,7 @@ testNotificationToken APNSMockServer {apnsQ} = do deleteNtfToken a tkn -- agent deleted this token Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn - liftIO $ disposeAgentClient a + pure () (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString v .-> key = do @@ -193,8 +195,7 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO () testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do -- setLogLevel LogError -- LogDebug -- withGlobalLogging logCfg $ do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -211,15 +212,13 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do -- can still use the first verification code, it is the same after decryption verifyNtfToken a tkn nonce verification NTActive <- checkNtfToken a tkn - liftIO $ disposeAgentClient a + pure () testNtfTokenSecondRegistration :: APNSMockServer -> IO () -testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do +testNtfTokenSecondRegistration APNSMockServer {apnsQ} = -- setLogLevel LogError -- LogDebug -- withGlobalLogging logCfg $ do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgentClients2 $ \a a' -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -248,37 +247,34 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do -- and the second is active NTActive <- checkNtfToken a' tkn pure () - disposeAgentClient a - disposeAgentClient a' testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestart t APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB let tkn = DeviceToken PPApnsTest "abcd" - ntfData <- withNtfServer t . runRight $ do - NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- - atomically $ readTBQueue apnsQ - liftIO $ sendApnsResponse APNSRespOk - pure ntfData - -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server + ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> + withNtfServer t . runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + pure ntfData + -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server threadDelay 1000000 - disposeAgentClient a - a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, - -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServer t . runRight_ $ do - verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" - Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <- - atomically $ readTBQueue apnsQ - verification' <- ntfData' .-> "verification" - nonce' <- C.cbNonce <$> ntfData' .-> "nonce" - liftIO $ sendApnsResponse' APNSRespOk - verifyNtfToken a' tkn nonce' verification' - NTActive <- checkNtfToken a' tkn - liftIO $ disposeAgentClient a' + withAgent 2 agentCfg initAgentServers testDB $ \a' -> + -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, + -- so that repeat verification happens without restarting the clients, when notification arrives + withNtfServer t . runRight_ $ do + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <- + atomically $ readTBQueue apnsQ + verification' <- ntfData' .-> "verification" + nonce' <- C.cbNonce <$> ntfData' .-> "nonce" + liftIO $ sendApnsResponse' APNSRespOk + verifyNtfToken a' tkn nonce' verification' + NTActive <- checkNtfToken a' tkn + pure () getTestNtfTokenPort :: AgentClient -> AE String getTestNtfTokenPort a = @@ -289,66 +285,62 @@ getTestNtfTokenPort a = testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do let tkn = DeviceToken PPApnsTest "abcd" - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - withNtfServerThreadOn t ntfTestPort $ \ntf -> - withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do - -- register a new token, the agent picks a server and stores its choice - NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- - atomically $ readTBQueue apnsQ - verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" - liftIO $ sendApnsResponse APNSRespOk - verifyNtfToken a tkn nonce verification - NTActive <- checkNtfToken a tkn - -- shut down the "other" server - port <- getTestNtfTokenPort a - liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf - -- still works - NTActive <- checkNtfToken a tkn - liftIO . killThread $ if port == ntfTestPort then ntf else ntf2 - -- negative test, the correct server is now gone - Left _ <- tryError (checkNtfToken a tkn) - pure () + withAgent 1 agentCfg initAgentServers2 testDB $ \a -> + withNtfServerThreadOn t ntfTestPort $ \ntf -> + withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do + -- register a new token, the agent picks a server and stores its choice + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + liftIO $ sendApnsResponse APNSRespOk + verifyNtfToken a tkn nonce verification + NTActive <- checkNtfToken a tkn + -- shut down the "other" server + port <- getTestNtfTokenPort a + liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf + -- still works + NTActive <- checkNtfToken a tkn + liftIO . killThread $ if port == ntfTestPort then ntf else ntf2 + -- negative test, the correct server is now gone + Left _ <- tryError (checkNtfToken a tkn) + pure () testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO () testNtfTokenChangeServers t APNSMockServer {apnsQ} = withNtfServerThreadOn t ntfTestPort $ \ntf -> do - tkn1 <- runRight $ do - a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB + tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do tkn <- registerTestToken a "abcd" NMInstant apnsQ NTActive <- checkNtfToken a tkn liftIO $ setNtfServers a [testNtfServer2] NTActive <- checkNtfToken a tkn -- still works on old server - liftIO $ disposeAgentClient a pure tkn threadDelay 1000000 - a <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ do - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort - NTActive <- checkNtfToken a tkn1 - liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed - -- trigger token replace - tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed - deleteNtfToken a tkn2 -- force server switch - Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now - getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated - killThread ntf - withNtfServerOn t ntfTestPort2 $ runRight_ $ do - tkn <- registerTestToken a "qwer" NMInstant apnsQ - checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive + withAgent 2 agentCfg initAgentServers testDB $ \a -> do + runRight_ $ do + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort + NTActive <- checkNtfToken a tkn1 + liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed + -- trigger token replace + tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed + deleteNtfToken a tkn2 -- force server switch + Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now + getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated + killThread ntf + withNtfServerOn t ntfTestPort2 $ runRight_ $ do + tkn <- registerTestToken a "qwer" NMInstant apnsQ + checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) testRunNTFServerTests t srv = - withNtfServerThreadOn t ntfTestPort $ \ntf -> do - a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB - r <- testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing - killThread ntf - pure r + withNtfServerOn t ntfTestPort $ + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do @@ -383,11 +375,9 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message -- aliceNtf client doesn't have subscription and is allowed to get notification message - aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB - runRight_ $ do + withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message pure () - disposeAgentClient aliceNtf runRight_ $ do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False @@ -459,10 +449,8 @@ registerTestToken a token mode apnsQ = do pure tkn testChangeNotificationsMode :: APNSMockServer -> IO () -testChangeNotificationsMode APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do +testChangeNotificationsMode APNSMockServer {apnsQ} = + withAgentClients2 $ \alice bob -> runRight_ $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -518,17 +506,13 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do ackMessage alice bobId (baseId + 5) Nothing -- no notifications should follow noNotification apnsQ - disposeAgentClient alice - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () -testChangeToken APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- runRight $ do +testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do + (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -547,10 +531,8 @@ testChangeToken APNSMockServer {apnsQ} = do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 1) Nothing pure (aliceId, bobId) - disposeAgentClient alice - alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do subscribeConnection alice1 bobId -- change notification token void $ registerTestToken alice1 "bcde" NMInstant apnsQ @@ -563,16 +545,12 @@ testChangeToken APNSMockServer {apnsQ} = do ackMessage alice1 bobId (baseId + 2) Nothing -- no notifications should follow noNotification apnsQ - disposeAgentClient alice1 - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () -testNotificationsStoreLog t APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ @@ -594,13 +572,9 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId - disposeAgentClient alice - disposeAgentClient bob testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestart t APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ @@ -626,49 +600,44 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do _ <- messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId - disposeAgentClient alice - disposeAgentClient bob testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2 - threadDelay 1000000 - conns <- runServers $ do - conns <- replicateM (n :: Int) $ makeConnection a b - _ <- registerTestToken a "abcd" NMInstant apnsQ - liftIO $ threadDelay 5000000 - forM_ conns $ \(aliceId, bobId) -> do - msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello" - get b ##> ("", aliceId, SENT msgId) - void $ messageNotificationData a apnsQ - get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage a bobId msgId Nothing - pure conns +testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = + withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do + threadDelay 1000000 + conns <- runServers $ do + conns <- replicateM (n :: Int) $ makeConnection a b + _ <- registerTestToken a "abcd" NMInstant apnsQ + liftIO $ threadDelay 5000000 + forM_ conns $ \(aliceId, bobId) -> do + msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello" + get b ##> ("", aliceId, SENT msgId) + void $ messageNotificationData a apnsQ + get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False + ackMessage a bobId msgId Nothing + pure conns - runRight_ @AgentErrorType $ do - ("", "", DOWN _ bcs1) <- nGet a - ("", "", DOWN _ bcs2) <- nGet a - liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns - ("", "", DOWN _ acs1) <- nGet b - ("", "", DOWN _ acs2) <- nGet b - liftIO $ length (acs1 <> acs2) `shouldBe` length conns + runRight_ @AgentErrorType $ do + ("", "", DOWN _ bcs1) <- nGet a + ("", "", DOWN _ bcs2) <- nGet a + liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns + ("", "", DOWN _ acs1) <- nGet b + ("", "", DOWN _ acs2) <- nGet b + liftIO $ length (acs1 <> acs2) `shouldBe` length conns - runServers $ do - ("", "", UP _ bcs1) <- nGet a - ("", "", UP _ bcs2) <- nGet a - liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns - ("", "", UP _ acs1) <- nGet b - ("", "", UP _ acs2) <- nGet b - liftIO $ length (acs1 <> acs2) `shouldBe` length conns - liftIO $ threadDelay 1500000 - forM_ conns $ \(aliceId, bobId) -> do - msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again" - get b ##> ("", aliceId, SENT msgId) - _ <- messageNotificationData a apnsQ - get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False - disposeAgentClient a - disposeAgentClient b + runServers $ do + ("", "", UP _ bcs1) <- nGet a + ("", "", UP _ bcs2) <- nGet a + liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns + ("", "", UP _ acs1) <- nGet b + ("", "", UP _ acs2) <- nGet b + liftIO $ length (acs1 <> acs2) `shouldBe` length conns + liftIO $ threadDelay 1500000 + forM_ conns $ \(aliceId, bobId) -> do + msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again" + get b ##> ("", aliceId, SENT msgId) + _ <- messageNotificationData a apnsQ + get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False where runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do @@ -679,10 +648,8 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do pure res testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () -testSwitchNotifications servers APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchNotifications servers APNSMockServer {apnsQ} = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId _ <- registerTestToken a "abcd" NMInstant apnsQ @@ -698,15 +665,10 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do switchComplete a bId b aId liftIO $ threadDelay 500000 testMessage "hello again" - disposeAgentClient a - disposeAgentClient b testNotificationsOldToken :: APNSMockServer -> IO () -testNotificationsOldToken APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testNotificationsOldToken APNSMockServer {apnsQ} = + withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b let testMessageAB = testMessage_ apnsQ a abId b baId _ <- registerTestToken a "abcd" NMInstant apnsQ @@ -722,16 +684,10 @@ testNotificationsOldToken APNSMockServer {apnsQ} = do (acId, caId) <- makeConnection a c let testMessageAC = testMessage_ apnsQ a acId c caId testMessageAC "greetings" - disposeAgentClient a - disposeAgentClient b - disposeAgentClient c testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO () -testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = + withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b let testMessageAB = testMessage_ apnsQ a abId b baId tkn <- registerTestToken a "abcd" NMInstant apnsQ @@ -750,9 +706,6 @@ testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do (acId, caId) <- makeConnection a c let testMessageAC = testMessage_ apnsQ a acId c caId testMessageAC "greetings" - disposeAgentClient a - disposeAgentClient b - disposeAgentClient c testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO () testMessage_ apnsQ a aId b bId msg = do diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 330a3f14c..3e5e9d2ce 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -123,7 +123,7 @@ withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceNa withSmpServerConfigOn t cfg' port' = serverBracket (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]}) - (pure ()) + (threadDelay 10000) withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerThreadOn t = withSmpServerConfigOn t cfg diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index a9c80762d..09cf975c1 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -769,7 +769,7 @@ testTiming (ATransport t) = (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.15 -- normally the difference between "no queue" and "wrong key" is less than 5% + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5% testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 2b7d01c35..a4e6c8d48 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -8,7 +8,7 @@ module XFTPAgent where -import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet) +import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent) import Control.Logger.Simple import Control.Monad @@ -24,7 +24,7 @@ import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), F import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) -import Simplex.Messaging.Agent (AgentClient, disposeAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) +import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv) import qualified Simplex.Messaging.Crypto as C @@ -100,8 +100,7 @@ testXFTPAgentSendReceive :: HasCallStack => IO () testXFTPAgentSendReceive = withXFTPServer $ do filePath <- createRandomFile -- send file, delete snd file internally - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (rfd1, rfd2) <- runRight $ do + (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSend sndr filePath liftIO $ xftpDeleteSndFileInternal sndr sfId pure (rfd1, rfd2) @@ -109,11 +108,10 @@ testXFTPAgentSendReceive = withXFTPServer $ do testReceiveDelete 2 rfd1 filePath testReceiveDelete 3 rfd2 filePath where - testReceiveDelete clientId rfd originalFilePath = do - rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2 - rfId <- runRight $ testReceive rcp rfd originalFilePath - xftpDeleteRcvFile rcp rfId - disposeAgentClient rcp + testReceiveDelete clientId rfd originalFilePath = + withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do + rfId <- runRight $ testReceive rcp rfd originalFilePath + xftpDeleteRcvFile rcp rfId testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO () testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do @@ -122,8 +120,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do s <- LB.readFile filePath file <- atomically $ CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs g runRight_ $ CF.writeFile file s - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (rfd1, rfd2) <- runRight $ do + (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSendCF sndr file liftIO $ xftpDeleteSndFileInternal sndr sfId pure (rfd1, rfd2) @@ -131,12 +128,11 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do testReceiveDelete 2 rfd1 filePath g testReceiveDelete 3 rfd2 filePath g where - testReceiveDelete clientId rfd originalFilePath g = do - rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2 - cfArgs <- atomically $ Just <$> CF.randomArgs g - rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath - xftpDeleteRcvFile rcp rfId - disposeAgentClient rcp + testReceiveDelete clientId rfd originalFilePath g = + withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do + cfArgs <- atomically $ Just <$> CF.randomArgs g + rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath + xftpDeleteRcvFile rcp rfId testXFTPAgentSendReceiveRedirect :: HasCallStack => IO () testXFTPAgentSendReceiveRedirect = withXFTPServer $ do @@ -144,102 +140,98 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do filePathIn <- createRandomFile let fileSize = mb 17 totalSize = fileSize + mb 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) - vfdDirect <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) + vfdDirect <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r - testNoRedundancy vfdDirect + testNoRedundancy vfdDirect - redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1 - logInfo $ "File sent, sending redirect: " <> tshow redirectFileId - sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536) - vfdRedirect@(ValidFileDescription fdRedirect) <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r + redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1 + logInfo $ "File sent, sending redirect: " <> tshow redirectFileId + sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536) + vfdRedirect@(ValidFileDescription fdRedirect) <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r - testNoRedundancy vfdRedirect + testNoRedundancy vfdRedirect - case fdRedirect of - FileDescription {redirect = Just _} -> pure () - _ -> error "missing RedirectFileInfo" - let uri = strEncode $ fileDescriptionURI vfdRedirect - case strDecode uri of - Left err -> fail err - Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect - disposeAgentClient sndr - --- recipient - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - FileDescriptionURI {description} <- either fail pure $ strDecode uri + case fdRedirect of + FileDescription {redirect = Just _} -> pure () + _ -> error "missing RedirectFileInfo" + let uri = strEncode $ fileDescriptionURI vfdRedirect + case strDecode uri of + Left err -> fail err + Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect + --- recipient + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + FileDescriptionURI {description} <- either fail pure $ strDecode uri - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) - out <- - rfGet rcp >>= \case - (_, _, RFDONE out) -> pure out - r -> error $ "Expected RFDONE, got " <> show r - disposeAgentClient rcp + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) + out <- + rfGet rcp >>= \case + (_, _, RFDONE out) -> pure out + r -> error $ "Expected RFDONE, got " <> show r - inBytes <- B.readFile filePathIn - B.readFile out `shouldReturn` inBytes + inBytes <- B.readFile filePathIn + B.readFile out `shouldReturn` inBytes testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO () testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do --- sender let fileSize = mb 5 filePathIn <- createRandomFile_ fileSize "testfile" - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 - let totalSize = fileSize + mb 1 - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) - vfdDirect <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + let totalSize = fileSize + mb 1 + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) + vfdDirect <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r - testNoRedundancy vfdDirect + testNoRedundancy vfdDirect - let uri = strEncode $ fileDescriptionURI vfdDirect - B.length uri `shouldSatisfy` (< qrSizeLimit) - case strDecode uri of - Left err -> fail err - Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect - disposeAgentClient sndr - --- recipient - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - FileDescriptionURI {description} <- either fail pure $ strDecode uri - let ValidFileDescription FileDescription {redirect} = description - redirect `shouldBe` Nothing - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing - -- NO extra "RFPROG 65k 65k" before switching to real file - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) - out <- - rfGet rcp >>= \case - (_, _, RFDONE out) -> pure out - r -> error $ "Expected RFDONE, got " <> show r - disposeAgentClient rcp + let uri = strEncode $ fileDescriptionURI vfdDirect + B.length uri `shouldSatisfy` (< qrSizeLimit) + case strDecode uri of + Left err -> fail err + Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect + --- recipient + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + FileDescriptionURI {description} <- either fail pure $ strDecode uri + let ValidFileDescription FileDescription {redirect} = description + redirect `shouldBe` Nothing + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + -- NO extra "RFPROG 65k 65k" before switching to real file + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) + out <- + rfGet rcp >>= \case + (_, _, RFDONE out) -> pure out + r -> error $ "Expected RFDONE, got " <> show r - inBytes <- B.readFile filePathIn - B.readFile out `shouldReturn` inBytes + inBytes <- B.readFile filePathIn + B.readFile out `shouldReturn` inBytes createRandomFile :: HasCallStack => IO FilePath createRandomFile = createRandomFile' "testfile" @@ -298,52 +290,48 @@ logCfgNoLogs :: LogConfig logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False} testXFTPAgentReceiveRestore :: HasCallStack => IO () -testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do +testXFTPAgentReceiveRestore = do filePath <- createRandomFile - rfd <- withXFTPServerStoreLogOn $ \_ -> do + rfd <- withXFTPServerStoreLogOn $ \_ -> -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (_, _, rfd, _) <- testSend sndr filePath pure rfd -- receive file - should not succeed with server down - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - rfId <- runRight $ do + rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) rfId <- xftpReceiveFile rcp 1 rfd Nothing liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId - disposeAgentClient rcp [prefixDir] <- listDirectory recipientFiles let tmpPath = recipientFiles prefixDir "xftp.encrypted" doesDirectoryExist tmpPath `shouldReturn` True - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- receive file - should start downloading with server up - rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFPROG _ _) <- rfGet rcp' - liftIO $ rfId' `shouldBe` rfId - disposeAgentClient rcp' - + withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + ("", rfId', RFPROG _ _) <- rfGet rcp' + liftIO $ rfId' `shouldBe` rfId threadDelay 100000 - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- receive file - should continue downloading with server up - rcp' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - rfProgress rcp' $ mb 18 - ("", rfId', RFDONE path) <- rfGet rcp' - liftIO $ do - rfId' `shouldBe` rfId - file <- B.readFile filePath - B.readFile path `shouldReturn` file + withAgent 4 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + rfProgress rcp' $ mb 18 + ("", rfId', RFDONE path) <- rfGet rcp' + liftIO $ do + rfId' `shouldBe` rfId + file <- B.readFile filePath + B.readFile path `shouldReturn` file - -- tmp path should be removed after receiving file - doesDirectoryExist tmpPath `shouldReturn` False + threadDelay 100000 + -- tmp path should be removed after receiving file + doesDirectoryExist tmpPath `shouldReturn` False testXFTPAgentReceiveCleanup :: HasCallStack => IO () testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do @@ -351,30 +339,27 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do rfd <- withXFTPServerStoreLogOn $ \_ -> do -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (_, _, rfd, _) <- testSend sndr filePath pure rfd -- receive file - should not succeed with server down - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - rfId <- runRight $ do + rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) rfId <- xftpReceiveFile rcp 1 rfd Nothing liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId - disposeAgentClient rcp [prefixDir] <- listDirectory recipientFiles let tmpPath = recipientFiles prefixDir "xftp.encrypted" doesDirectoryExist tmpPath `shouldReturn` True - withXFTPServerThreadOn $ \_ -> do + withXFTPServerThreadOn $ \_ -> -- receive file - should fail with AUTH error - rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' - rfId' `shouldBe` rfId + withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' + rfId' `shouldBe` rfId -- tmp path should be removed after permanent error doesDirectoryExist tmpPath `shouldReturn` False @@ -384,13 +369,11 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile -- send file - should not succeed with server down - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - sfId <- runRight $ do + sfId <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file pure sfId - disposeAgentClient sndr dirEntries <- listDirectory senderFiles let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries @@ -399,25 +382,25 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do doesDirectoryExist prefixPath `shouldReturn` True doesFileExist encPath `shouldReturn` True - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- send file - should start uploading with server up - sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFPROG _ _) <- sfGet sndr' - liftIO $ sfId' `shouldBe` sfId - disposeAgentClient sndr' + withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + ("", sfId', SFPROG _ _) <- sfGet sndr' + liftIO $ sfId' `shouldBe` sfId threadDelay 100000 withXFTPServerStoreLogOn $ \_ -> do -- send file - should continue uploading with server up - sndr' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - sfProgress sndr' $ mb 18 - ("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr' - liftIO $ testNoRedundancy rfd1 - liftIO $ testNoRedundancy rfd2 - liftIO $ sfId' `shouldBe` sfId + rfd1 <- withAgent 3 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + sfProgress sndr' $ mb 18 + ("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr' + liftIO $ testNoRedundancy rfd1 + liftIO $ testNoRedundancy rfd2 + liftIO $ sfId' `shouldBe` sfId + pure rfd1 -- prefix path should be removed after sending file threadDelay 100000 @@ -425,18 +408,16 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do doesFileExist encPath `shouldReturn` False -- receive file - rcp <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1 filePath + withAgent 4 agentCfg initAgentServers testDB2 $ \rcp -> + runRight_ . void $ testReceive rcp rfd1 filePath testXFTPAgentSendCleanup :: HasCallStack => IO () testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile - sfId <- withXFTPServerStoreLogOn $ \_ -> do + sfId <- withXFTPServerStoreLogOn $ \_ -> -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - sfId <- runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 -- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server @@ -444,8 +425,6 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do (_, _, SFPROG _ _) <- sfGet sndr pure () pure sfId - disposeAgentClient sndr - pure sfId dirEntries <- listDirectory senderFiles let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries @@ -454,16 +433,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do doesDirectoryExist prefixPath `shouldReturn` True doesFileExist encPath `shouldReturn` True - withXFTPServerThreadOn $ \_ -> do + withXFTPServerThreadOn $ \_ -> -- send file - should fail with AUTH error - sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr' - sfId' `shouldBe` sfId + withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr' + sfId' `shouldBe` sfId - -- prefix path should be removed after permanent error - doesDirectoryExist prefixPath `shouldReturn` False - doesFileExist encPath `shouldReturn` False + -- prefix path should be removed after permanent error + doesDirectoryExist prefixPath `shouldReturn` False + doesFileExist encPath `shouldReturn` False testXFTPAgentDelete :: HasCallStack => IO () testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ @@ -471,32 +450,30 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ filePath <- createRandomFile -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath - -- receive file - rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp1 rfd1 filePath + -- receive file + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do + runRight_ . void $ testReceive rcp1 rfd1 filePath - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - -- delete file - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr - Nothing <- 100000 `timeout` sfGet sndr - disposeAgentClient rcp1 + -- delete file + runRight_ $ xftpStartWorkers sndr (Just senderFiles) + xftpDeleteSndFileRemote sndr 1 sfId sndDescr + Nothing <- 100000 `timeout` sfGet sndr + pure () - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file - should fail with AUTH error - rcp2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 - liftIO $ rfId' `shouldBe` rfId + -- receive file - should fail with AUTH error + withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do + xftpStartWorkers rcp2 (Just recipientFiles) + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteRestore :: HasCallStack => IO () testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do @@ -504,42 +481,37 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do (sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath - -- receive file - rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp1 rfd1 filePath - disposeAgentClient rcp1 - disposeAgentClient sndr - pure (sfId, sndDescr, rfd2) + -- receive file + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> + runRight_ . void $ testReceive rcp1 rfd1 filePath + pure (sfId, sndDescr, rfd2) -- delete file - should not succeed with server down - sndr <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr - timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt - disposeAgentClient sndr + withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do + runRight_ $ xftpStartWorkers sndr (Just senderFiles) + xftpDeleteSndFileRemote sndr 1 sfId sndDescr + timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt threadDelay 300000 length <$> listDirectory xftpServerFiles `shouldReturn` 6 withXFTPServerStoreLogOn $ \_ -> do -- delete file - should succeed with server up - sndr' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file - should fail with AUTH error - rcp2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB3 - runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 - liftIO $ rfId' `shouldBe` rfId + -- receive file - should fail with AUTH error + withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do + xftpStartWorkers rcp2 (Just recipientFiles) + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteOnServer :: HasCallStack => IO () testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ @@ -547,36 +519,35 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ filePath1 <- createRandomFile' "testfile1" -- send file 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 - -- receive file 1 successfully - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1_1 filePath1 + -- receive file 1 successfully + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + runRight_ . void $ testReceive rcp rfd1_1 filePath1 - serverFiles <- listDirectory xftpServerFiles - length serverFiles `shouldBe` 6 + serverFiles <- listDirectory xftpServerFiles + length serverFiles `shouldBe` 6 - -- delete file 1 on server from file system - forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) + -- delete file 1 on server from file system + forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- create and send file 2 - filePath2 <- createRandomFile' "testfile2" - (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 + -- create and send file 2 + filePath2 <- createRandomFile' "testfile2" + (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - runRight_ . void $ do - -- receive file 1 again - -- TODO should fail with AUTH error - _rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing + runRight_ . void $ do + -- receive file 1 again + -- TODO should fail with AUTH error + _rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing - -- receive file 2 - testReceive' rcp rfd2 filePath2 + -- receive file 2 + testReceive' rcp rfd2 filePath2 testXFTPAgentExpiredOnServer :: HasCallStack => IO () testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do @@ -585,46 +556,43 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do filePath1 <- createRandomFile' "testfile1" -- send file 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 - -- receive file 1 successfully - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1_1 filePath1 + -- receive file 1 successfully + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + runRight_ . void $ testReceive rcp rfd1_1 filePath1 - serverFiles <- listDirectory xftpServerFiles - length serverFiles `shouldBe` 6 + serverFiles <- listDirectory xftpServerFiles + length serverFiles `shouldBe` 6 - -- wait until file 1 expires on server - forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) + -- wait until file 1 expires on server + forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) - threadDelay 3500000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 3500000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file 1 again - should fail with AUTH error - runRight $ do - rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp - liftIO $ rfId' `shouldBe` rfId + -- receive file 1 again - should fail with AUTH error + runRight $ do + rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp + liftIO $ rfId' `shouldBe` rfId - -- create and send file 2 - filePath2 <- createRandomFile' "testfile2" - (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 + -- create and send file 2 + filePath2 <- createRandomFile' "testfile2" + (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - -- receive file 2 successfully - runRight_ . void $ - testReceive' rcp rfd2 filePath2 + -- receive file 2 successfully + runRight_ . void $ testReceive' rcp rfd2 filePath2 testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO () testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do filePath <- createRandomFile -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - rfds <- runRight $ do + rfds <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500 sfProgress sndr $ mb 18 @@ -638,8 +606,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do -- receive file using different descriptions -- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight_ $ do void $ testReceive rcp (head rfds) filePath void $ testReceive rcp (rfds !! 99) filePath void $ testReceive rcp (rfds !! 299) filePath @@ -647,6 +614,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure) testXFTPServerTest newFileBasicAuth srv = - withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running - testProtocolServer a 1 srv + withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> + -- initially passed server is not running + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 srv diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 57c33094d..d42ee7d06 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -5,7 +5,7 @@ module XFTPClient where -import Control.Concurrent (ThreadId) +import Control.Concurrent (ThreadId, threadDelay) import Data.String (fromString) import Network.Socket (ServiceName) import SMPClient (serverBracket) @@ -53,7 +53,7 @@ withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => Thread withXFTPServerCfg cfg = serverBracket (`runXFTPServerBlocking` cfg) - (pure ()) + (threadDelay 10000) withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig