Improve cluster setup reliability

lib/shelley/bench/latency-bench.hs

@@ -39,7 +39,6 @@ import Cardano.Wallet.Api.Types
     , ApiUtxoStatistics
     , ApiWallet
     , ApiWalletMigrationPlan (..)
-    , EncodeAddress (..)
     , WalletStyle (..)
     )
 import Cardano.Wallet.LatencyBenchShared
@@ -68,18 +67,16 @@ import Cardano.Wallet.Shelley.Faucet
 import Cardano.Wallet.Shelley.Launch
     ( withSystemTempDir )
 import Cardano.Wallet.Shelley.Launch.Cluster
-    ( LocalClusterConfig (..)
+    ( FaucetFunds (..)
+    , LocalClusterConfig (..)
     , LogFileConfig (..)
     , RunningNode (..)
     , defaultPoolConfigs
-    , sendFaucetAssetsTo
     , walletListenFromEnv
     , withCluster
     )
 import Cardano.Wallet.Unsafe
     ( unsafeFromText )
-import Control.Arrow
-    ( first )
 import Control.Monad
     ( replicateM, replicateM_ )
 import Control.Monad.IO.Class
@@ -146,7 +143,6 @@ import UnliftIO.STM
     ( TVar )
 
 import qualified Cardano.Wallet.Api.Link as Link
-import qualified Data.Text as T
 import qualified Network.HTTP.Types.Status as HTTP
 
 main :: forall n. (n ~ 'Mainnet) => IO ()
@@ -467,18 +463,23 @@ withShelleyServer tracers action = do
                     [head defaultPoolConfigs]
                     maxBound
                     logCfg
-            let initialFunds =
-                    shelleyIntegrationTestFunds
-                    <> byronIntegrationTestFunds
-            withCluster nullTracer dir clusterCfg initialFunds $
-                onClusterStart act db dir
-
-    onClusterStart act db dir (RunningNode conn block0 (np, vData) _) = do
-
-        let encodeAddr = T.unpack . encodeAddress @'Mainnet
-        let addressesMA = map (first encodeAddr) (maryIntegrationTestAssets (Coin 10_000_000))
-        sendFaucetAssetsTo nullTracer conn dir 20 addressesMA
-
+            withCluster
+                nullTracer
+                dir
+                clusterCfg
+                faucetFunds
+                (onClusterStart act db)
+
+    faucetFunds = FaucetFunds
+        { pureAdaFunds =
+            shelleyIntegrationTestFunds
+             <> byronIntegrationTestFunds
+        , maFunds =
+            maryIntegrationTestAssets (Coin 10_000_000)
+        , mirFunds = [] -- not needed
+        }
+
+    onClusterStart act db (RunningNode conn block0 (np, vData) _) = do
         listen <- walletListenFromEnv
         serveWallet
             (NodeSource conn vData (SyncTolerance 10))

lib/shelley/exe/local-cluster.hs

@@ -28,7 +28,7 @@ import Cardano.CLI
 import Cardano.Startup
     ( installSignalHandlers, setDefaultFilePermissions, withUtf8Encoding )
 import Cardano.Wallet.Api.Types
-    ( EncodeAddress (..), decodeAddress )
+    ( decodeAddress )
 import Cardano.Wallet.Logging
     ( stdoutTextTracer, trMessageText )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -50,11 +50,10 @@ import Cardano.Wallet.Shelley.Launch
 import Cardano.Wallet.Shelley.Launch.Cluster
     ( ClusterLog (..)
     , Credential (..)
+    , FaucetFunds (..)
     , RunningNode (..)
     , localClusterConfigFromEnv
-    , moveInstantaneousRewardsTo
     , oneMillionAda
-    , sendFaucetAssetsTo
     , testMinSeverityFromEnv
     , tokenMetadataServerFromEnv
     , walletListenFromEnv
@@ -218,26 +217,21 @@ main = withLocalClusterSetup $ \dir clusterLogs walletLogs ->
   where
     unsafeDecodeAddr = either (error . show) id . decodeAddress @'Mainnet
 
-    faucetFunds =
+    faucetFunds = FaucetFunds
+        { pureAdaFunds =
             shelleyIntegrationTestFunds
              <> byronIntegrationTestFunds
              <> map (first unsafeDecodeAddr) hwWalletFunds
+        , maFunds =
+            maryIntegrationTestAssets (Coin 10_000_000)
+        , mirFunds =
+            first KeyCredential
+            . (,Coin $ fromIntegral oneMillionAda)
+            <$> concatMap genRewardAccounts mirMnemonics
+        }
 
-    setupFaucet dir trCluster (RunningNode socketPath _ _ _) = do
-        traceWith trCluster MsgSettingUpFaucet
-        let trCluster' = contramap MsgCluster trCluster
-        let encodeAddresses = map (first (T.unpack . encodeAddress @'Mainnet))
-        let accts = KeyCredential <$> concatMap genRewardAccounts mirMnemonics
-        let rewards' = (, Coin $ fromIntegral oneMillionAda) <$> accts
-
-        sendFaucetAssetsTo trCluster' socketPath dir 20 $ encodeAddresses $
-            maryIntegrationTestAssets (Coin 1_000_000_000)
-        moveInstantaneousRewardsTo trCluster' socketPath dir rewards'
-
-    whenReady dir trCluster logs node@(RunningNode socketPath block0 (gp, vData) _) =
+    whenReady dir trCluster logs (RunningNode socketPath block0 (gp, vData) _) =
         withLoggingNamed "cardano-wallet" logs $ \(sb, (cfg, tr)) -> do
-            setupFaucet dir trCluster node
-
             ekgEnabled >>= flip when (EKG.plugin cfg tr sb >>= loadPlugin sb)
 
             let tracers = setupTracers (tracerSeverities (Just Debug)) tr

lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs

@@ -28,6 +28,7 @@ module Cardano.Wallet.Shelley.Launch.Cluster
     , LocalClusterConfig (..)
     , localClusterConfigFromEnv
     , ClusterEra (..)
+    , FaucetFunds (..)
 
       -- * Node launcher
     , NodeParams (..)
@@ -124,7 +125,11 @@ import Cardano.Startup
 import Cardano.Wallet.Api.Server
     ( Listen (..) )
 import Cardano.Wallet.Api.Types
-    ( ApiEra (..), DecodeAddress (..), HealthStatusSMASH (..) )
+    ( ApiEra (..)
+    , DecodeAddress (..)
+    , EncodeAddress (..)
+    , HealthStatusSMASH (..)
+    )
 import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer )
 import Cardano.Wallet.Network.Ports
@@ -159,6 +164,8 @@ import Cardano.Wallet.Util
     ( mapFirst )
 import Codec.Binary.Bech32.TH
     ( humanReadablePart )
+import Control.Arrow
+    ( first )
 import Control.Monad
     ( forM, forM_, liftM2, replicateM, replicateM_, void, when, (>=>) )
 import Control.Retry
@@ -433,6 +440,9 @@ data ConfiguredPool = ConfiguredPool
       -- ^ The 'PoolRecipe' used to create this 'ConfiguredPool'.
     , registerViaShelleyGenesis
         :: IO (ShelleyGenesis StandardShelley -> ShelleyGenesis StandardShelley)
+    , finalizeShelleyGenesisSetup :: RunningNode -> IO ()
+      -- ^ Submit any pool retirement certificate according to the 'recipe'
+      -- on-chain.
     , registerViaTx :: RunningNode -> IO ()
     }
 
@@ -534,21 +544,8 @@ configurePool tr baseDir metadataServer recipe = do
                         , nodePort = Just (NodePort port)
                         , nodeLoggingHostname = Just name
                         }
-                withCardanoNodeProcess tr name cfg $ \socket -> do
-                    -- Here is our chance to respect the 'retirementEpoch' of
-                    -- the 'PoolRecipe'.
-                    --
-                    -- NOTE: We also submit the retirement cert in
-                    -- @registerViaTx@, but this seems to work regardless. (We
-                    -- do want to submit it here for the sake of babbage)
-                    let retire e = do
-                            retCert <- issuePoolRetirementCert tr dir opPub e
-                            (rawTx, faucetPrv) <- preparePoolRetirement tr dir [retCert]
-                            tx <- signTx tr dir rawTx [faucetPrv, ownerPrv, opPrv]
-                            submitTx tr socket "retirement cert" tx
-
-                    traverse_ retire mretirementEpoch
 
+                withCardanoNodeProcess tr name cfg $ \socket -> do
                     action $ RunningNode socket block0 (bp, vd) genesisPools
 
         , registerViaShelleyGenesis = do
@@ -581,10 +578,26 @@ configurePool tr baseDir metadataServer recipe = do
                     }
             let poolSpecificFunds = Map.fromList
                     [(pledgeAddr, Ledger.Coin $ intCast pledgeAmt)]
+
             return $ \sg -> sg
                 { sgInitialFunds = poolSpecificFunds <> (sgInitialFunds sg)
                 , sgStaking = updateStaking (sgStaking sg)
                 }
+
+        , finalizeShelleyGenesisSetup = \(RunningNode socket _ _ _) -> do
+            -- Here is our chance to respect the 'retirementEpoch' of
+            -- the 'PoolRecipe'.
+            --
+            -- NOTE: We also submit the retirement cert in
+            -- @registerViaTx@, but this seems to work regardless. (We
+            -- do want to submit it here for the sake of babbage)
+            let retire e = do
+                    retCert <- issuePoolRetirementCert tr dir opPub e
+                    (rawTx, faucetPrv) <- preparePoolRetirement tr dir [retCert]
+                    tx <- signTx tr dir rawTx [faucetPrv, ownerPrv, opPrv]
+                    submitTx tr socket "retirement cert" tx
+
+            traverse_ retire mretirementEpoch
         , registerViaTx = \(RunningNode socket _ _ _) -> do
             stakeCert <- issueStakeVkCert tr dir "stake-pool" ownerPub
             let poolRegistrationCert = dir </> "pool.cert"
@@ -603,6 +616,7 @@ configurePool tr baseDir metadataServer recipe = do
                 , "--out-file", poolRegistrationCert
                 ]
 
+
             mPoolRetirementCert <- traverse
                 (issuePoolRetirementCert tr dir opPub) mretirementEpoch
             dlgCert <- issueDlgCert tr dir ownerPub opPub
@@ -964,6 +978,26 @@ generateGenesis dir systemStart initialFunds addPoolsToGenesis = do
         | (Address addrBytes, Coin c) <- initialFunds
         ]
 
+data FaucetFunds = FaucetFunds
+    { pureAdaFunds :: [(Address, Coin)]
+      -- ^ Pure ada funds
+    , maFunds :: [(Address, (TokenBundle, [(String, String)]))]
+      -- ^ Multi asset funds. Slower to setup than pure ada funds.
+      --
+      -- Beside the assets, there is a list of
+      -- @(signing key, verification key hash)@, so that they can be minted by
+      -- the faucet.
+    , mirFunds :: [(Credential, Coin)]
+      -- ^ "Move instantaneous rewards" - for easily funding reward accounts.
+    } deriving (Eq, Show)
+
+instance Semigroup FaucetFunds where
+    FaucetFunds ada1 ma1 mir1 <> FaucetFunds ada2 ma2 mir2
+        = FaucetFunds (ada1 <> ada2) (ma1 <> ma2) (mir1 <> mir2)
+
+instance Monoid FaucetFunds where
+    mempty = FaucetFunds [] [] []
+
 -- | Execute an action after starting a cluster of stake pools. The cluster also
 -- contains a single BFT node that is pre-configured with keys available in the
 -- test data.
@@ -984,11 +1018,11 @@ withCluster
     -- ^ Temporary directory to create config files in.
     -> LocalClusterConfig
     -- ^ The configurations of pools to spawn.
-    -> [(Address, Coin)] -- Faucet funds
+    -> FaucetFunds
     -> (RunningNode -> IO a)
-    -- ^ Action to run once when the stake pools are setup.
+    -- ^ Action to run once when all pools have started.
     -> IO a
-withCluster tr dir LocalClusterConfig{..} initialFunds onClusterStart = bracketTracer' tr "withCluster" $ do
+withCluster tr dir LocalClusterConfig{..} faucetFunds onClusterStart = bracketTracer' tr "withCluster" $ do
     withPoolMetadataServer tr dir $ \metadataServer -> do
         createDirectoryIfMissing True dir
         traceWith tr $ MsgStartingCluster dir
@@ -1011,13 +1045,22 @@ withCluster tr dir LocalClusterConfig{..} initialFunds onClusterStart = bracketT
         genesisFiles <- generateGenesis
             dir
             systemStart
-            (initialFunds <> faucetFunds)
+            (adaFunds <> internalFaucetFunds)
             (if postAlonzo then addGenesisPools else federalizeNetwork)
 
         if postAlonzo
         then do
-            ports <- rotate <$> randomUnusedTCPPorts nPools
-            launchPools configuredPools genesisFiles ports onClusterStart'
+            port0:ports <- rotate <$> randomUnusedTCPPorts nPools
+            let pool0:otherPools = configuredPools
+
+            let pool0Cfg = NodeParams
+                    genesisFiles
+                    cfgLastHardFork
+                    port0
+                    cfgNodeLogging
+            operatePool pool0 pool0Cfg $ \runningPool0 -> do
+                extraClusterSetupUsingNode configuredPools runningPool0
+                launchPools otherPools genesisFiles ports onClusterStart
         else do
             ports <- rotate <$> randomUnusedTCPPorts (1 + nPools)
             let bftCfg = NodeParams
@@ -1026,24 +1069,45 @@ withCluster tr dir LocalClusterConfig{..} initialFunds onClusterStart = bracketT
                     (head ports)
                     cfgNodeLogging
             withBFTNode tr dir bftCfg $ \runningBFTNode -> do
+                extraClusterSetupUsingNode configuredPools runningBFTNode
+
                 -- NOTE: We used to perform 'registerViaTx' as part of 'launchPools'
                 -- where we waited for the pools to become active (e.g. be in
                 -- the stake distribution) in parallel. Just submitting the
                 -- registration certs in sequence /seems/ to work though, and the
                 -- setup working 100% correctly in alonzo will soon not be
                 -- important.
                 mapM_ (`registerViaTx` runningBFTNode) configuredPools
-                launchPools configuredPools genesisFiles (tail ports) onClusterStart'
+                launchPools configuredPools genesisFiles (tail ports) onClusterStart
   where
     nPools = length cfgStakePools
 
     postAlonzo = cfgLastHardFork >= BabbageHardFork
 
-    onClusterStart' node@(RunningNode socket _ _ _) = do
+    FaucetFunds adaFunds maFunds mirFunds = faucetFunds
+
+    -- Important cluster setup to run without rollbacks
+    extraClusterSetupUsingNode :: [ConfiguredPool] -> RunningNode -> IO ()
+    extraClusterSetupUsingNode configuredPools runningNode = do
+        let RunningNode conn _ _ _ = runningNode
+
+        -- Needs to happen in the first 20% of the epoch, so we run this
+        -- first.
+        moveInstantaneousRewardsTo tr conn dir mirFunds
+
+        sendFaucetAssetsTo tr conn dir 20 (encodeAddresses maFunds)
+
+        -- Submit retirement certs for all pools using the connection to
+        -- the only running first pool to avoid the certs being rolled
+        -- back.
+        when postAlonzo $
+            forM_ configuredPools $ \pool -> do
+                finalizeShelleyGenesisSetup pool runningNode
+
+        -- Should ideally not be hard-coded in 'withCluster'
         (rawTx, faucetPrv) <- prepareKeyRegistration tr dir
         tx <- signTx tr dir rawTx [faucetPrv]
-        submitTx tr socket "pre-registered stake key" tx
-        onClusterStart node
+        submitTx tr conn "pre-registered stake key" tx
 
     -- | Actually spin up the pools.
     launchPools
@@ -1114,6 +1178,8 @@ withCluster tr dir LocalClusterConfig{..} initialFunds onClusterStart = bracketT
     rotate :: Ord a => [a] -> [(a, [a])]
     rotate = nub . fmap (\(x:xs) -> (x, sort xs)) . permutations
 
+    encodeAddresses = map (first (T.unpack . encodeAddress @'W.Mainnet))
+
 data LogFileConfig = LogFileConfig
     { minSeverityTerminal :: Severity
       -- ^ Minimum logging severity
@@ -1783,6 +1849,7 @@ batch s xs = forM_ (group s xs)
 data Credential
     = KeyCredential XPub
     | ScriptCredential ByteString
+    deriving (Eq, Show)
 
 moveInstantaneousRewardsTo
     :: Tracer IO ClusterLog
@@ -2005,8 +2072,8 @@ faucetIndex = unsafePerformIO $ newMVar 1
 --
 -- FIXME: We should generate these programatically. Currently they need to match
 -- the files on disk read by 'takeFaucet'.
-faucetFunds :: [(Address, Coin)]
-faucetFunds = map
+internalFaucetFunds :: [(Address, Coin)]
+internalFaucetFunds = map
     ((,Coin 1000000000000000) . unsafeDecodeAddr . T.pack)
   [ "Ae2tdPwUPEZGc7WAmkmXxP3QJ8aiKSMGgfWV6w4A58ebjpr5ah147VvJfDH"
   , "Ae2tdPwUPEZCREUZxa3F1fTyVPMU2MLMYAkRe7DEVoyZsWKahphgdifWuc3"