From c547677aed7d0d74515ea98a3c39e99a3b4a0022 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Wed, 22 May 2024 10:34:32 +0200 Subject: [PATCH 1/3] Log failures to delegate in setupDelegation --- .../framework/Test/Integration/Framework/Logging.hs | 7 +++++++ .../framework/Test/Integration/Framework/Setup.hs | 8 ++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/lib/integration/framework/Test/Integration/Framework/Logging.hs b/lib/integration/framework/Test/Integration/Framework/Logging.hs index ce40031854f..02e167e1f1c 100644 --- a/lib/integration/framework/Test/Integration/Framework/Logging.hs +++ b/lib/integration/framework/Test/Integration/Framework/Logging.hs @@ -89,6 +89,7 @@ data TestsLog | MsgCluster ClusterLog | MsgPoolGarbageCollectionEvent PoolGarbageCollectionEvent | MsgServerError SomeException + | MsgRewardWalletDelegationFailed Text deriving (Show) instance ToText TestsLog where @@ -120,6 +121,11 @@ instance ToText TestsLog where | isAsyncException (SomeException e) -> "Server thread cancelled: " <> T.pack (show e) | otherwise -> T.pack (show e) + MsgRewardWalletDelegationFailed msg -> + T.unlines + [ "Reward wallet delegation failed." + , "Details: " <> toText msg + ] instance HasPrivacyAnnotation TestsLog instance HasSeverityAnnotation TestsLog where @@ -132,6 +138,7 @@ instance HasSeverityAnnotation TestsLog where MsgServerError e | isAsyncException e -> Notice | otherwise -> Warning + MsgRewardWalletDelegationFailed{} -> Error withTracers :: DirOf "cluster" diff --git a/lib/integration/framework/Test/Integration/Framework/Setup.hs b/lib/integration/framework/Test/Integration/Framework/Setup.hs index 2c1dfefc08a..84f9b29ab33 100644 --- a/lib/integration/framework/Test/Integration/Framework/Setup.hs +++ b/lib/integration/framework/Test/Integration/Framework/Setup.hs @@ -535,13 +535,17 @@ withContext testingCtx@TestingCtx{..} action = do -- resources for unnecessary restoration. forM_ mnemonics $ \mw -> runResourceT $ do w <- walletFromMnemonic ctx mw - _ <- + (httpStatus, res) <- joinStakePool @('Testnet 0) -- protocol magic doesn't matter ctx (SpecificPool pool) (w, fixturePassphrase) - pure () + liftIO $ case res of + Right _ -> return () + Left err -> traceWith tr + $ MsgRewardWalletDelegationFailed + $ T.pack $ show (httpStatus, err) bracketTracer' :: Tracer IO TestsLog -> Text -> IO a -> IO a bracketTracer' tr name = bracketTracer $ contramap (MsgBracket name) tr From ffa6545774bc07766ab6cdb79d65c50a3ebeecdf Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Wed, 22 May 2024 20:19:20 +0200 Subject: [PATCH 2/3] Reduce number of rewardWallet mnemonics from 30 to 25 --- lib/local-cluster/lib/Cardano/Wallet/Faucet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Faucet.hs b/lib/local-cluster/lib/Cardano/Wallet/Faucet.hs index 4782b065aac..b00708a3c78 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Faucet.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Faucet.hs @@ -322,7 +322,7 @@ preregKeyWallet tag = do rewardWalletMnemonicRange :: MnemonicRange rewardWalletMnemonicRange = - MnemonicRange 0 30 + MnemonicRange 0 25 -- As few as possible; the cardano-wallet integration tests need to call -- postWallet for each one at the beginning of the tests. From 70a761ace7aba504646436f0deb6cca3cb50573d Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Wed, 22 May 2024 20:29:16 +0200 Subject: [PATCH 3/3] Keep all wallets in `setupDelegation` alive longer --- .../Test/Integration/Framework/Setup.hs | 42 ++++++++++++------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/lib/integration/framework/Test/Integration/Framework/Setup.hs b/lib/integration/framework/Test/Integration/Framework/Setup.hs index 84f9b29ab33..f7ef5d89453 100644 --- a/lib/integration/framework/Test/Integration/Framework/Setup.hs +++ b/lib/integration/framework/Test/Integration/Framework/Setup.hs @@ -123,6 +123,9 @@ import Cardano.Wallet.TokenMetadata.MockServer ( queryServerStatic , withMetadataServer ) +import Control.Concurrent + ( threadDelay + ) import Control.Lens ( view ) @@ -530,22 +533,29 @@ withContext testingCtx@TestingCtx{..} action = do ctx (Link.listStakePools arbitraryStake) Empty - -- Having 'runResourceT' /inside/ the loop ensures the wallets are - -- deleted as quickly as possible, not to deplete file descriptors or - -- resources for unnecessary restoration. - forM_ mnemonics $ \mw -> runResourceT $ do - w <- walletFromMnemonic ctx mw - (httpStatus, res) <- - joinStakePool - @('Testnet 0) -- protocol magic doesn't matter - ctx - (SpecificPool pool) - (w, fixturePassphrase) - liftIO $ case res of - Right _ -> return () - Left err -> traceWith tr - $ MsgRewardWalletDelegationFailed - $ T.pack $ show (httpStatus, err) + + -- We only delete the wallets together at the end of the loop by + -- using this /outer/ 'runResourceT'. While this may be taxing on + -- resources, it enables tx submission to ensure all txs make it into + -- the chain. + runResourceT $ do + forM_ mnemonics $ \mw -> do + w <- walletFromMnemonic ctx mw + (httpStatus, res) <- + joinStakePool + @('Testnet 0) -- protocol magic doesn't matter + ctx + (SpecificPool pool) + (w, fixturePassphrase) + liftIO $ case res of + Left err -> traceWith tr + $ MsgRewardWalletDelegationFailed + $ T.pack $ show (httpStatus, err) + Right _ -> return () + + -- Extra time to ensure the final txs make it into the chain + let second = 1_000_000 + liftIO $ threadDelay $ 10 * second bracketTracer' :: Tracer IO TestsLog -> Text -> IO a -> IO a bracketTracer' tr name = bracketTracer $ contramap (MsgBracket name) tr