Speed up smoke tests

hydra-cluster/README.md

@@ -54,6 +54,12 @@ start `cardano-node`.
 The Hydra nodes can reference pre-existing contracts living at some well-known
 transaction or can post a new transaction to use those contracts.
 
+The scenario runs with a shorter `deposit-activation` and contestation period
+than the end-to-end tests use (see `mkSmokeTiming`): most of its wall clock would
+otherwise be spent waiting those out. The contestation period stops at the point
+where the validity window of close, contest and increment transactions would
+start shrinking, so nothing is more likely to expire than before.
+
 :warning: do not provide actual funds to this faucet address as the
 signing key is publicly available. Shall you want to run the smoke
 test with actual funds, you shall override these file to use a secret

hydra-cluster/exe/hydra-cluster/Main.hs

@@ -19,6 +19,7 @@ import Hydra.Cluster.Fixture (Actor (Faucet), KnownNetwork (..))
 import Hydra.Cluster.Mithril (downloadLatestSnapshotTo)
 import Hydra.Cluster.Options (Options (..), PublishOrReuse (Publish, Reuse), Scenario (..), UseMithril (UseMithril), parseOptions)
 import Hydra.Cluster.Scenarios (respendNTimes, singlePartyHeadFullLifeCycle, singlePartyOpenAHead)
+import Hydra.Cluster.Util (mkSmokeTiming)
 import Hydra.Logging (Tracer, traceWith, withTracerOutputTo)
 import Hydra.Options (BlockfrostOptions (..), ChainBackendOptions (..), defaultBlockfrostOptions)
 import Options.Applicative (ParserInfo, execParser, fullDesc, header, helper, info, progDesc)
@@ -43,12 +44,12 @@ run options =
             then withRunningCardanoNode tracer workDir network $ \_ opts -> do
               waitForFullySynchronized fromCardanoNode (Direct opts)
               publishOrReuseHydraScripts tracer (Direct opts)
-                >>= singlePartyHeadFullLifeCycle tracer workDir (Direct opts)
+                >>= singlePartyHeadFullLifeCycle tracer workDir mkSmokeTiming (Direct opts)
             else do
               bfProjectPath <- findFileStartingAtDirectory 3 blockfrostProjectPath
               let opts = Blockfrost defaultBlockfrostOptions{projectPath = bfProjectPath}
               publishOrReuseHydraScripts tracer opts
-                >>= singlePartyHeadFullLifeCycle tracer workDir opts
+                >>= singlePartyHeadFullLifeCycle tracer workDir mkSmokeTiming opts
         Nothing -> do
           withCardanoNodeDevnet fromCardanoNode workDir $ \_ opts -> do
             txId <- publishOrReuseHydraScripts tracer (Direct opts)

hydra-cluster/hydra-cluster.cabal

@@ -162,6 +162,7 @@ test-suite tests
     Test.Hydra.Cluster.HydraClientSpec
     Test.Hydra.Cluster.MithrilSpec
     Test.Hydra.Cluster.Utils
+    Test.Hydra.Cluster.UtilSpec
     Test.OfflineChainSpec
 
   build-depends:

hydra-cluster/src/Hydra/Cluster/Faucet.hs

@@ -81,29 +81,70 @@ seedFromFaucetWithMinting ::
   Tracer IO FaucetLog ->
   Maybe PlutusScript ->
   IO UTxO
-seedFromFaucetWithMinting opts receivingVerificationKey val tracer mintingScript = do
+seedFromFaucetWithMinting opts receivingVerificationKey val tracer mintingScript =
+  seedManyFromFaucetWithMinting opts [(receivingVerificationKey, val)] tracer mintingScript >>= \case
+    [utxo] -> pure utxo
+    utxos -> failure $ "seedFromFaucetWithMinting: expected one seeded UTxO, got " <> show (length utxos)
+
+-- | Like 'seedFromFaucet' but pays every recipient from a single faucet
+-- transaction. A scenario needing more than one funded key then waits for one
+-- confirmation instead of one per key, which is a block time each on a public
+-- network.
+seedManyFromFaucet ::
+  ChainBackendOptions ->
+  -- | Recipients of the funds and the value each is to receive.
+  [(VerificationKey PaymentKey, Value)] ->
+  Tracer IO FaucetLog ->
+  -- | The seeded UTxO of each recipient, in the order given.
+  IO [UTxO]
+seedManyFromFaucet opts recipients tracer =
+  seedManyFromFaucetWithMinting opts recipients tracer Nothing
+
+seedManyFromFaucetWithMinting ::
+  ChainBackendOptions ->
+  -- | Recipients of the funds and the value each is to receive.
+  [(VerificationKey PaymentKey, Value)] ->
+  Tracer IO FaucetLog ->
+  Maybe PlutusScript ->
+  -- | The seeded UTxO of each recipient, in the order given.
+  IO [UTxO]
+seedManyFromFaucetWithMinting _ [] _ _ = pure []
+seedManyFromFaucetWithMinting opts recipients tracer mintingScript = do
   (faucetVk, faucetSk) <- keysFor Faucet
   networkId <- runBackend opts queryNetworkId
   seedTx <- retryOnExceptions tracer opts $ submitSeedTx faucetVk faucetSk networkId
-  producedUTxO <- runBackend opts $ awaitTransaction seedTx receivingVerificationKey
-  pure $ UTxO.filter (== toCtxUTxOTxOut (theOutput networkId)) producedUTxO
+  -- NOTE: The direct backend's 'awaitTransaction' yields all of the tx's
+  -- outputs while the Blockfrost one yields only those paying to the given key,
+  -- so ask per recipient and filter. Only the first call waits for the
+  -- transaction, the rest are already satisfied by it.
+  forM recipients $ \(vk, val) -> do
+    seeded <-
+      UTxO.filter (== toCtxUTxOTxOut (theOutput networkId vk val))
+        <$> runBackend opts (awaitTransaction seedTx vk)
+    -- An empty result means the output we asked for is not the one that landed
+    -- (a value normalised on the way out, say). Say so here rather than let the
+    -- caller trip over an empty UTxO much later.
+    when (UTxO.null seeded) $
+      failure $
+        "seedManyFromFaucet: no output of " <> show val <> " for " <> show vk <> " in " <> show (getTxId $ getTxBody seedTx)
+    pure seeded
  where
   submitSeedTx faucetVk faucetSk networkId = do
-    faucetUTxO <- findFaucetUTxO networkId opts (selectLovelace val)
+    faucetUTxO <- findFaucetUTxO networkId opts (sum $ selectLovelace . snd <$> recipients)
     let changeAddress = mkVkAddress networkId faucetVk
+    let outputs = uncurry (theOutput networkId) <$> recipients
 
-    runBackend opts (buildTransactionWithMintingScript changeAddress faucetUTxO (toList $ UTxO.inputSet faucetUTxO) [theOutput networkId] mintingScript) >>= \case
+    runBackend opts (buildTransactionWithMintingScript changeAddress faucetUTxO (toList $ UTxO.inputSet faucetUTxO) outputs mintingScript) >>= \case
       Left e -> throwIO $ FaucetFailedToBuildTx{reason = e}
       Right tx -> do
         let signedTx = sign faucetSk (getTxBody tx)
         runBackend opts $ submitTransaction signedTx
         pure signedTx
 
-  receivingAddress = buildAddress receivingVerificationKey
-
-  theOutput networkId =
+  theOutput :: NetworkId -> VerificationKey PaymentKey -> Value -> TxOut CtxTx
+  theOutput networkId vk val =
     TxOut
-      (shelleyAddressInEra shelleyBasedEra (receivingAddress networkId))
+      (shelleyAddressInEra shelleyBasedEra (buildAddress vk networkId))
       val
       TxOutDatumNone
       ReferenceScriptNone

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -51,7 +51,7 @@ import Hydra.Cardano.Api (
   Coin (..),
   Era,
   File (File),
-  Key (SigningKey),
+  Key (SigningKey, VerificationKey),
   KeyWitnessInCtx (..),
   LedgerProtocolParameters (..),
   PaymentKey,
@@ -104,18 +104,17 @@ import Hydra.Cardano.Api qualified as CAPI
 import Hydra.Chain (PostTxError (..))
 import Hydra.Chain.Backend (ChainBackend (..), buildTransaction, buildTransactionWithPParams, buildTransactionWithPParams')
 import Hydra.Chain.ChainState (ChainSlot (..))
-import Hydra.Cluster.Faucet (createOutputAtAddress, seedFromFaucet, seedFromFaucet_)
+import Hydra.Cluster.Faucet (createOutputAtAddress, seedFromFaucet, seedFromFaucet_, seedManyFromFaucet)
 import Hydra.Cluster.Faucet qualified as Faucet
 import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk, carol, carolSk, carolVk)
-import Hydra.Cluster.Util (Timing (..), chainConfigFor, chainConfigFor', depositTimeout, keysFor, mkTestTiming, mkTestTiming', modifyConfig, nodeStartupBudget, setNetworkId, truncatedDepositPeriod)
+import Hydra.Cluster.Util (BlockTime, Timing (..), chainConfigFor, chainConfigFor', depositTimeout, keysFor, mkTestTiming, mkTestTiming', modifyConfig, nodeStartupBudget, setNetworkId, truncatedDepositPeriod)
 import Hydra.Contract.Dummy (dummyRewardingScript, dummyValidatorScript)
 import Hydra.Ledger.Cardano (mkSimpleTx, mkTransferTx, unsafeBuildTransaction)
 import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network qualified as Network
 import Hydra.Node.UnsyncedPeriod (defaultUnsyncedPeriodFor, unsyncedPeriodToNominalDiffTime)
 import Hydra.Options (CardanoChainConfig (..), ChainBackendOptions (..), ChainConfig (..), DirectOptions (..), RunOptions (..), startChainFrom)
 import Hydra.Tx (HeadId (..), IsTx (balance), Party, txId)
-import Hydra.Tx.ContestationPeriod qualified as CP
 import Hydra.Tx.Crypto (getVerificationKey, signTx)
 import Hydra.Tx.Deposit (constructDepositUTxO)
 import Hydra.Tx.Secret (Secret, mkSecret)
@@ -519,35 +518,44 @@ nodeReObservesOnChainTxs tracer workDir opts hydraScriptsTxId = do
 
 -- | Step through the full life cycle of a Hydra Head with only a single
 -- participant. This scenario is also used by the smoke test run via the
--- `hydra-cluster` executable.
+-- `hydra-cluster` executable, which passes 'mkSmokeTiming' rather than
+-- 'mkTestTiming' on the networks where the protocol waits dominate.
 singlePartyHeadFullLifeCycle ::
   Tracer IO EndToEndLog ->
   FilePath ->
+  -- | How to derive the timing parameters from the chain's block time.
+  (BlockTime -> Timing) ->
   ChainBackendOptions ->
   [TxId] ->
   IO ()
-singlePartyHeadFullLifeCycle tracer workDir opts hydraScriptsTxId =
+singlePartyHeadFullLifeCycle tracer workDir mkTiming opts hydraScriptsTxId =
   (`finally` returnFundsToFaucet tracer opts Alice) $ do
-    refuelIfNeeded tracer opts Alice 55_000_000
-    -- Start hydra-node on chain tip
-    tip <- runBackend opts queryTip
     blockTime <- runBackend opts getBlockTime
     networkId <- runBackend opts queryNetworkId
-    let timing = mkTestTiming blockTime
-    let Timing{depositPeriod = timingDepositPeriod, depositActivation = timingDepositActivation} = timing
-    contestationPeriod <- CP.fromNominalDiffTime $ 20 * blockTime
-    aliceChainConfig <-
-      chainConfigFor' Alice workDir opts hydraScriptsTxId [] contestationPeriod timingDepositPeriod timingDepositActivation
-        <&> modifyConfig (\config -> config{startChainFrom = Just tip})
-          . setNetworkId networkId
+    let timing = mkTiming blockTime
+
+    -- NOTE: Take the tip before funding, so the funding transaction is
+    -- guaranteed to land after it. The node is started at this point and only
+    -- leaves 'CatchingUp' on a chain tick, which is emitted on roll forward
+    -- alone -- pinned to the bare tip it would sit there until the next block.
+    tip <- runBackend opts queryTip
 
     (aliceCardanoVk, aliceCardanoSk) <- keysFor Alice
     let aliceAddress = mkVkAddress networkId aliceCardanoVk
 
-    -- Prepare deposit payload
+    -- Prepare deposit payload. Alice's fuel and the wallet's deposit come from
+    -- one faucet transaction, so this costs a single confirmation.
     (walletVk, walletSk) <- generate genKeyPair
     let depositAmount = 10_000_000
-    depositUTxO <- seedFromFaucet opts walletVk (lovelaceToValue depositAmount) (contramap FromFaucet tracer)
+    depositUTxO <-
+      refuelAndSeed tracer opts Alice 55_000_000 [(walletVk, lovelaceToValue depositAmount)] >>= \case
+        [utxo] -> pure utxo
+        utxos -> failure $ "expected exactly one seeded deposit UTxO, got " <> show (length utxos)
+
+    aliceChainConfig <-
+      chainConfigFor Alice workDir opts hydraScriptsTxId [] timing
+        <&> modifyConfig (\config -> config{startChainFrom = Just tip})
+          . setNetworkId networkId
     let changeAddress = mkVkAddress @Era networkId walletVk
     let (i, o) = List.head $ UTxO.toList depositUTxO
     let witness = BuildTxWith $ KeyWitness KeyWitnessForSpending
@@ -2106,14 +2114,33 @@ refuelIfNeeded ::
   Actor ->
   Coin ->
   IO ()
-refuelIfNeeded tracer opts actor amount = do
+refuelIfNeeded tracer opts actor amount =
+  void $ refuelAndSeed tracer opts actor amount []
+
+-- | Like 'refuelIfNeeded', but seeds further keys from the same faucet
+-- transaction and returns their UTxO. Each faucet transaction costs an on-chain
+-- confirmation, a block time on a public network, so a scenario needing several
+-- funded keys is better off asking for them together.
+refuelAndSeed ::
+  Tracer IO EndToEndLog ->
+  ChainBackendOptions ->
+  Actor ->
+  -- | Amount the actor is to hold before the scenario starts.
+  Coin ->
+  -- | Further keys to seed, and the value each is to receive.
+  [(VerificationKey PaymentKey, CAPI.Value)] ->
+  -- | The seeded UTxO of each further key, in the order given.
+  IO [UTxO]
+refuelAndSeed tracer opts actor amount seeds = do
   (actorVk, _) <- keysFor actor
   existingUtxo <- runBackend opts $ queryUTxOFor QueryTip actorVk
   traceWith tracer $ StartingFunds{actor = actorName actor, utxo = existingUtxo}
-  let currentBalance = selectLovelace $ balance @Tx existingUtxo
-  when (currentBalance < amount) $ do
-    utxo <- seedFromFaucet opts actorVk (lovelaceToValue amount) (contramap FromFaucet tracer)
+  let refuel = [(actorVk, lovelaceToValue amount) | selectLovelace (balance @Tx existingUtxo) < amount]
+  seeded <- seedManyFromFaucet opts (refuel <> seeds) (contramap FromFaucet tracer)
+  let (refueled, seededUTxO) = splitAt (length refuel) seeded
+  forM_ refueled $ \utxo ->
     traceWith tracer $ RefueledFunds{actor = actorName actor, refuelingAmount = amount, utxo}
+  pure seededUTxO
 
 -- | Return the remaining funds to the faucet
 returnFundsToFaucet ::

hydra-cluster/src/Hydra/Cluster/Util.hs

@@ -107,6 +107,47 @@ mkTestTiming' numDeposits blockTime =
  where
   depositPeriod = truncatedDepositPeriod $ fromIntegral numDeposits * 20 * blockTime
 
+-- | Timing for the smoke test run by the @hydra-cluster@ executable against a
+-- public network, where a block takes ~20s and the run is dominated by waiting
+-- out 'depositActivation' rather than by anything the scenario asserts.
+--
+-- A deposit becomes active at @created + depositActivation@, where @created@ is
+-- the deposit tx's upper validity bound, set a grace time ahead of the chain
+-- tip by 'Hydra.Chain.Direct.Handlers.draftDepositTx'. That grace time is
+-- @maxGraceTime \`min\` untilDeadline / 2@, and a backticked function binds
+-- tighter than @\/@, so it is @min 200 untilDeadline / 2@: a flat 100s for any
+-- deadline more than 200s out, not the @min 200 (untilDeadline \/ 2)@ it reads
+-- as. So the wait is @100 + depositActivation@, and only the second term is
+-- ours: at one block time it drops from 100 + 400 to 100 + 20.
+--
+-- 'contestationPeriod' is cut to the point where the close transaction's
+-- validity window stops changing, and no further. The contestation deadline is
+-- @closeTxUpperBound + contestationPeriod@ with the close tx bounded at
+-- @now + min contestationPeriod maxGraceTime@, so at @10 * blockTime@ = 200s
+-- the wait halves from 600s to 400s while that @min@ still yields 200s, exactly
+-- as it does at 'mkTestTiming'\'s 400s. Going below 200s would start shortening
+-- the window every close, contest and increment has to be included in, with no
+-- resubmit on expiry, and would drag two things with it: the derived
+-- @unsyncedPeriod@ (half the contestation period, against a Blockfrost follower
+-- that only observes blocks with a successor and so lags a block gap by
+-- construction) and 'Hydra.Chain.Blockfrost.Client.submissionRetryPolicy',
+-- whose ~180s worst case is documented against a 200s window.
+--
+-- 'depositPeriod' keeps its 'mkTestTiming' value. It is not on the critical
+-- path -- it sets how long a deposit stays active, not how long anything waits
+-- -- and shortening it only eats that window, which is
+-- @depositPeriod - graceTime@. NOTE: This assumes block times around 20s; the
+-- window closes entirely below ~5s, where 'depositPeriod' falls to the flat
+-- 100s grace time. 'Test.Hydra.Cluster.UtilSpec' guards the value used here.
+mkSmokeTiming :: BlockTime -> Timing
+mkSmokeTiming blockTime =
+  Timing
+    { blockTime
+    , contestationPeriod = truncate $ max 1 (10 * blockTime)
+    , depositPeriod = truncatedDepositPeriod $ max 1 (20 * blockTime)
+    , depositActivation = truncatedDepositPeriod $ max 1 blockTime
+    }
+
 -- | Get a timeout until a deposit should have happened given a 'Timing'. A
 -- deposit becomes active after 'depositActivation' and then needs about one
 -- 'depositPeriod' to be picked up and incremented, so both are accounted for

hydra-cluster/test/Main.hs

@@ -13,6 +13,7 @@ import Test.Hydra.Cluster.CardanoCliSpec qualified
 import Test.Hydra.Cluster.FaucetSpec qualified
 import Test.Hydra.Cluster.HydraClientSpec qualified
 import Test.Hydra.Cluster.MithrilSpec qualified
+import Test.Hydra.Cluster.UtilSpec qualified
 import Test.Hydra.TastyMain (hydraTestTree, runHydraTests, testSpec)
 import Test.OfflineChainSpec qualified
 import Test.Tasty (localOption)
@@ -48,6 +49,7 @@ main = do
       , testSpec "Hydra.Cluster.Faucet" Test.Hydra.Cluster.FaucetSpec.spec
       , testSpec "Hydra.Cluster.HydraClient" Test.Hydra.Cluster.HydraClientSpec.spec
       , testSpec "Hydra.Cluster.Mithril" Test.Hydra.Cluster.MithrilSpec.spec
+      , testSpec "Hydra.Cluster.Util" Test.Hydra.Cluster.UtilSpec.spec
       , testSpec "OfflineChain" Test.OfflineChainSpec.spec
       ]
   runHydraTests "hydra-cluster" (localOption (NumThreads 1) tree)

hydra-cluster/test/Test/EndToEndSpec.hs

@@ -242,7 +242,7 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do
       it "full head life-cycle" $ \tracer ->
         withClusterTempDir $ \tmpDir ->
           withHydraScriptsAndBackendRunning tracer tmpDir $
-            singlePartyHeadFullLifeCycle tracer tmpDir
+            singlePartyHeadFullLifeCycle tracer tmpDir mkTestTiming
       it "can close with long deadline" $ \tracer ->
         withClusterTempDir $ \tmpDir ->
           withHydraScriptsAndBackendRunning tracer tmpDir $