From 1e3b882eaac98857b8dd0c953102e48d76394c6d Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Sat, 11 Jul 2026 02:55:59 +0200 Subject: [PATCH 1/3] cardano-testnet: fail fast with a diagnosis when the chain stalls irrecoverably A `cardano-testnet` network permanently stops producing blocks whenever no block is forged for longer than the ledger view forecast horizon of `3 * securityParam / activeSlotsCoeff` slots - `300 slots = 30s` of wall clock with the default genesis options (`securityParam=5`, `activeSlotsCoeff=0.05`, `slotLength=0.1s`). Past that point every node fails its leadership check with `Forge.Loop.NoLedgerView` and the chain can never extend again. This happens when node startup exceeds the start-time offset (`startTimeOffsetSeconds`, `15s`) plus the horizon, or when an overloaded machine starves the nodes of CPU for longer than the horizon mid-run, and it made tests hang forever in chain-progress waits (`waitForEpochs`/`waitForBlocks`/`waitUntilEpoch`) whose deadlines are measured in epochs/blocks/slots that never arrive. Detect the situation instead, as early as it is provable, and explain it: * `chainForecastHorizon` computes the horizon from the `ShelleyGenesis` backing the testnet (read via the node configuration); the stall threshold is `max 60s (2 * horizon)` - `60s` with the default genesis - falling back to a conservative `300s` when the genesis cannot be read. * `retryUntilRightM`: when no chain-state update arrives for the whole stall threshold (previously a silently swallowed `300s` fallback), fail with a message explaining the mechanism, the actual horizon, and pointing at the node logs. * `waitUntilEpoch`: `race` `foldEpochState` against a stall watchdog with the same semantics and diagnostic. * `waitForBlockThrow`: the startup deadline is now derived from the genesis (`startTimeOffsetSeconds + horizon + 15s` margin instead of a flat `45s`) and the error explains the likely cause and remedy. Attempts to fix #5762 (the hangs) --- .../20260711_032508_palas_testnet_hang_fix.md | 5 + .../src/Testnet/Components/Query.hs | 148 +++++++++++++++++- cardano-testnet/src/Testnet/Start/Cardano.hs | 22 ++- 3 files changed, 162 insertions(+), 13 deletions(-) create mode 100644 cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md diff --git a/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md b/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md new file mode 100644 index 00000000000..39ff0d6261a --- /dev/null +++ b/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md @@ -0,0 +1,5 @@ +## Fixed + +- Changed `retryUntilRightM` and `waitUntilEpoch` to fail if the chain dies. +- Make the timeout for testnet startup depend on the testnet config. + diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 8f085bd662f..1d5ecb074aa 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -23,6 +23,7 @@ module Testnet.Components.Query , getTreasuryValue , TestnetWaitPeriod (..) + , chainForecastHorizon , waitForEpochs , waitUntilEpoch , waitForBlocks @@ -53,14 +54,18 @@ import qualified Cardano.Api.UTxO as Utxo import Cardano.Ledger.Api (ConwayGovState) import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Api.State.Query as SQ +import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Conway.Governance as L import qualified Cardano.Ledger.Conway.PParams as L +import qualified Cardano.Ledger.Shelley.Genesis as SL import qualified Cardano.Ledger.Shelley.LedgerState as L +import qualified Cardano.Ledger.Shelley.StabilityWindow as SL import qualified Cardano.Ledger.State as L import Prelude import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM, TVar, modifyTVar', newTVarIO, readTVar, writeTVar) import qualified Control.Concurrent.STM as STM import Control.Monad @@ -73,12 +78,17 @@ import Data.Maybe import Data.Ord (Down (..)) import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Time.Clock as DTC import Data.Type.Equality import Data.Word (Word64) import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro (Lens', to, (^.)) +import System.FilePath (takeDirectory, ()) +import System.IO.Error (tryIOError) import Testnet.Process.RunIO (liftIOAnnotated) import Testnet.Property.Assert @@ -90,6 +100,7 @@ import qualified Hedgehog as H import Hedgehog.Extras (MonadAssertion) import qualified Hedgehog.Extras as H +import UnliftIO.Async (race) import UnliftIO.STM (atomically, readTVarIO, registerDelay) -- | Block and wait for the desired epoch. @@ -102,16 +113,31 @@ waitUntilEpoch -> EpochNo -- ^ Desired epoch -> m EpochNo -- ^ The epoch number reached waitUntilEpoch nodeConfigFile socketPath desiredEpoch = withFrozenCallStack $ do - result <- H.evalIO . runExceptT $ - foldEpochState - nodeConfigFile socketPath QuickValidation desiredEpoch () (\_ _ _ -> pure ConditionNotMet) + mHorizon <- fmap chainForecastHorizon <$> readShelleyGenesis nodeConfigFile + let stallTimeout = maybe fallbackChainStallTimeout chainStallTimeoutFromHorizon mHorizon + lastProgress <- H.evalIO $ do + now <- DTC.getCurrentTime + newIORef (now, Nothing) + result <- H.evalIO $ + race (chainStallWatchdog stallTimeout lastProgress) $ + runExceptT $ + foldEpochState nodeConfigFile socketPath QuickValidation desiredEpoch () $ + \_ slotNo blockNo -> do + liftIO $ do + now <- DTC.getCurrentTime + writeIORef lastProgress (now, Just (slotNo, blockNo)) + pure ConditionNotMet case result of - Left (FoldBlocksApplyBlockError (TerminationEpochReached epochNo)) -> + Left lastPoint -> do + H.note_ $ chainStallFailureMessage stallTimeout mHorizon + ("waiting for " <> show desiredEpoch) lastPoint + H.failure + Right (Left (FoldBlocksApplyBlockError (TerminationEpochReached epochNo))) -> pure epochNo - Left err -> do + Right (Left err) -> do H.note_ $ "waitUntilEpoch: could not reach termination epoch, " <> docToString (prettyError err) H.failure - Right res -> do + Right (Right res) -> do H.note_ $ "waitUntilEpoch: could not reach termination epoch - no error returned " <> "- invalid foldEpochState behaviour, result: " <> show res H.failure @@ -185,13 +211,106 @@ retryUntilRightM esv timeout act = withFrozenCallStack $ do cv <- getCurrentValue if cv > deadline then pure l - else awaitStateUpdateTimeout esv 300 versionBeforeAct *> go deadline + else + awaitStateUpdateTimeout esv (epochStallTimeout esv) versionBeforeAct >>= \case + Just _ -> go deadline + Nothing -> do + -- No chain-state update for the whole fallback window: the chain has + -- stopped extending and can never recover. Fail instead of looping forever. + lastState <- readTVarIO $ epochStateView esv + let lastPoint = either (const Nothing) (\(_, s, b) -> Just (s, b)) lastState + H.note_ $ chainStallFailureMessage (epochStallTimeout esv) (epochStallHorizon esv) + ("waiting for " <> show timeout) lastPoint + H.failure (getCurrentValue, timeoutW64) = case timeout of WaitForEpochs (EpochInterval n) -> (unEpochNo <$> getCurrentEpochNo esv, fromIntegral n) WaitForSlots n -> (unSlotNo <$> getSlotNumber esv, n) WaitForBlocks n -> (unBlockNo <$> getBlockNumber esv, n) +-- | How long a testnet chain may go without any new block before we conclude it is +-- permanently stalled, when the genesis backing the testnet cannot be read to compute +-- 'chainStallTimeoutFromHorizon'. Deliberately conservative: an order of magnitude +-- above the forecast horizon of the default genesis options. +fallbackChainStallTimeout :: DTC.NominalDiffTime +fallbackChainStallTimeout = 300 + +-- | The ledger view forecast horizon of the chain described by the given genesis: +-- @3 * securityParam / activeSlotsCoeff@ slots (the stability window), converted to +-- wall-clock time. Nodes can only forge while the wall-clock slot is at most this far +-- past the chain tip, so a chain that has not forged for longer than this can never +-- produce a block again: every node fails its leadership checks with +-- @Forge.Loop.NoLedgerView@. See https://github.com/IntersectMBO/cardano-node/issues/5762 +chainForecastHorizon :: ShelleyGenesis -> DTC.NominalDiffTime +chainForecastHorizon sg = + fromIntegral horizonSlots * SL.fromNominalDiffTimeMicro (sgSlotLength sg) + where + horizonSlots = + SL.computeStabilityWindow + (SL.unNonZero $ sgSecurityParam sg) + (SL.mkActiveSlotCoeff $ sgActiveSlotsCoeff sg) + +-- | Stall detection threshold for a chain with the given forecast horizon: twice the +-- horizon (a chain quiet for longer than the horizon is already irrecoverable; the +-- factor and the 60s floor absorb block-interval variance and detection latency). +chainStallTimeoutFromHorizon :: DTC.NominalDiffTime -> DTC.NominalDiffTime +chainStallTimeoutFromHorizon horizon = max 60 (2 * horizon) + +-- | Best-effort read of the Shelley genesis backing a node configuration: looks up the +-- @ShelleyGenesisFile@ key in the (JSON) node configuration, resolves it relative to the +-- configuration file's directory, and decodes the genesis. Returns 'Nothing' whenever +-- anything cannot be read, so callers can fall back to conservative defaults. +readShelleyGenesis :: MonadIO m => NodeConfigFile In -> m (Maybe ShelleyGenesis) +readShelleyGenesis (File configPath) = liftIO $ do + result <- tryIOError $ do + mConfig <- Aeson.decodeFileStrict' configPath + case Aeson.parseMaybe (Aeson.withObject "NodeConfig" (Aeson..: "ShelleyGenesisFile")) =<< mConfig of + Nothing -> pure Nothing + Just genesisPath -> Aeson.decodeFileStrict' $ takeDirectory configPath genesisPath + pure $ either (const Nothing) id result + +-- | Failure message explaining why a chain that stopped extending will never recover. +-- See https://github.com/IntersectMBO/cardano-node/issues/5762 +chainStallFailureMessage + :: DTC.NominalDiffTime -- ^ the stall-detection timeout that expired + -> Maybe DTC.NominalDiffTime -- ^ the chain's forecast horizon, when known + -> String -- ^ what we were waiting for + -> Maybe (SlotNo, BlockNo) -- ^ last observed chain state, if any + -> String +chainStallFailureMessage stallTimeout mHorizon while lastPoint = + unlines + [ "The testnet chain made no progress for " <> show stallTimeout <> " while " <> while <> "." + , case lastPoint of + Just (SlotNo slotNo, BlockNo blockNo) -> + "Last observed chain state: slot " <> show slotNo <> ", block " <> show blockNo <> "." + Nothing -> "No chain state update was observed at all." + , "The network is almost certainly stalled forever: nodes can only forge when the wall-clock" + , "slot is at most 3 * securityParam / activeSlotsCoeff slots past the chain tip - the ledger" + , "view forecast horizon, which is " <> horizonStr <> " of wall clock for this testnet." + , "Once no block was forged for longer than that - e.g. because node startup took too long or" + , "the machine was too overloaded to produce a block in time - every node fails its leadership" + , "checks and the chain can never extend again, so we fail fast instead of" + , "hanging." + ] + where + horizonStr = maybe "30s with the default genesis options" show mHorizon + +-- | Completes when the point tracked by the given 'IORef' has not moved for the given +-- stall timeout, returning the last observed point. +chainStallWatchdog + :: DTC.NominalDiffTime -- ^ stall timeout + -> IORef (DTC.UTCTime, Maybe (SlotNo, BlockNo)) + -> IO (Maybe (SlotNo, BlockNo)) +chainStallWatchdog stallTimeout lastProgress = go + where + go = do + threadDelay 5_000_000 + (lastUpdate, lastPoint) <- readIORef lastProgress + now <- DTC.getCurrentTime + if now `DTC.diffUTCTime` lastUpdate >= stallTimeout + then pure lastPoint + else go + -- | Retries the action until it returns 'Just' or the timeout is reached retryUntilJustM :: HasCallStack @@ -247,6 +366,14 @@ data EpochStateView = EpochStateView , epochStateVersion :: !(TVar Word64) -- ^ Monotonically increasing counter, bumped on every state write. -- Used by 'awaitStateUpdateTimeout' to block until the next update. + , epochStallTimeout :: !DTC.NominalDiffTime + -- ^ How long the chain may go without any new block before it is considered + -- irrecoverably stalled. Derived from the genesis backing the testnet in + -- 'getEpochStateView' (see 'chainStallTimeoutFromHorizon'), or + -- 'fallbackChainStallTimeout' when the genesis could not be read. + , epochStallHorizon :: !(Maybe DTC.NominalDiffTime) + -- ^ The ledger view forecast horizon of the chain ('chainForecastHorizon'), + -- when the genesis backing the testnet could be read. Used for diagnostics. } -- | Write a new value to the epoch state and bump the version counter atomically. @@ -386,7 +513,12 @@ getEpochStateView -> SocketPath -- ^ node socket path -> m EpochStateView getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do - esv <- H.evalIO $ EpochStateView <$> newTVarIO (Left EpochStateNotInitialised) <*> newTVarIO 0 + mHorizon <- fmap chainForecastHorizon <$> readShelleyGenesis nodeConfigFile + esv <- H.evalIO $ EpochStateView + <$> newTVarIO (Left EpochStateNotInitialised) + <*> newTVarIO 0 + <*> pure (maybe fallbackChainStallTimeout chainStallTimeoutFromHorizon mHorizon) + <*> pure mHorizon _ <- asyncRegister_ $ do result <- runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) () $ \epochState slotNumber blockNumber -> do diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index c4df60856cb..a7eeee86c34 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -75,6 +75,7 @@ import qualified System.Process as Process import System.FilePath (()) import Testnet.Components.Configuration +import Testnet.Components.Query (chainForecastHorizon) import qualified Testnet.Defaults as Defaults import Cardano.Node.Testnet.Paths (defaultConfigFile, defaultNodeEnvFile, defaultPortFile, defaultUtxoAddrPath) @@ -383,8 +384,13 @@ cardanoTestnet -- Interrupt cardano nodes when the main process is interrupted liftIOAnnotated $ interruptNodesOnSigINT testnetNodes' - -- Make sure that all nodes are healthy by waiting for a chain extension - mapConcurrently_ (waitForBlockThrow 45 (File nodeConfigFile)) testnetNodes' + -- Make sure that all nodes are healthy by waiting for a chain extension. + -- The deadline covers the worst case in which the chain can still start: genesis start + -- time lies at most 'startTimeOffsetSeconds' in the future, and the first block must + -- appear within the forecast horizon after it (see 'chainForecastHorizon'), plus margin. + let startupHorizon = chainForecastHorizon shelleyGenesis + startupBlockTimeout = startTimeOffsetSeconds + ceiling startupHorizon + 15 + mapConcurrently_ (waitForBlockThrow startupHorizon startupBlockTimeout (File nodeConfigFile)) testnetNodes' let runtime = TestnetRuntime { configurationFile = File nodeConfigFile @@ -428,11 +434,12 @@ cardanoTestnet -- wait for new blocks or throw an exception if there are none in the timeout period waitForBlockThrow :: MonadUnliftIO m => MonadCatch m - => Int -- ^ timeout in seconds + => DTC.NominalDiffTime -- ^ the chain's forecast horizon, for diagnostics + -> Int -- ^ timeout in seconds -> NodeConfigFile 'In -> TestnetNode -> m () - waitForBlockThrow timeoutSeconds nodeConfigFile node@TestnetNode{nodeName} = do + waitForBlockThrow horizon timeoutSeconds nodeConfigFile node@TestnetNode{nodeName} = do result <- timeout (timeoutSeconds * 1_000_000) $ runExceptT . foldEpochState nodeConfigFile @@ -453,7 +460,12 @@ cardanoTestnet Just (Left err) -> throwString $ "foldBlocks on " <> nodeName <> " encountered an error while waiting for new blocks: " <> show (prettyError err) _ -> - throwString $ nodeName <> " was unable to produce any blocks for " <> show timeoutSeconds <> "s" + throwString $ nodeName <> " was unable to produce any blocks for " <> show timeoutSeconds <> "s. " + <> "The testnet probably missed its startup window and can never produce a block: nodes can only forge " + <> "while the wall-clock slot is at most 3 * securityParam / activeSlotsCoeff slots past the " + <> "chain tip (" <> show horizon <> " of wall clock for this testnet), and the genesis start " + <> "time is set only " <> show startTimeOffsetSeconds <> "s after the testnet files are " + <> "created." idToRemoteAddressP2P :: () From 046640d9870dcfe2d2bcd82fcf45751f024b75f5 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Sat, 11 Jul 2026 19:03:08 +0000 Subject: [PATCH 2/3] cardano-testnet: guarantee node termination and bounded waits in test teardown Two teardown hardenings for overloaded machines, where a test suite run can wedge with no output at all - not even the per-test 600s watchdogs fire visibly - until the CI-level timeout kills it. * `initiateProcess` now releases processes with `cleanupProcessBounded` instead of `cleanupProcess`. The bounded variant waits a `15s` grace period and escalates to `SIGKILL`, which cannot be ignored or blocked, so node termination is guaranteed; if the process still survives (uninterruptible kernel sleep) it is leaked rather than waited on. * `asyncRegister_` no longer waits unboundedly for the cancelled thread: `H.cancel` blocks until the thread finishes, and resource release actions run with asynchronous exceptions masked, so a thread stuck in a foreign call would wedge the teardown forever with nothing able to interrupt it. Cap the wait at `15s` and leak the thread instead. --- .../src/Testnet/Components/Query.hs | 3 +- cardano-testnet/src/Testnet/Process/Run.hs | 50 ++++++++++++++++++- cardano-testnet/src/Testnet/Runtime.hs | 9 +++- 3 files changed, 59 insertions(+), 3 deletions(-) diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 1d5ecb074aa..9d56316d112 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -71,6 +71,7 @@ import qualified Control.Concurrent.STM as STM import Control.Monad import Control.Monad.Trans.Maybe (MaybeT (..), mapMaybeT, runMaybeT) import Control.Monad.Trans.Resource +import Data.Either (fromRight) import Data.List (sortOn) import qualified Data.Map as Map import Data.Map.Strict (Map) @@ -267,7 +268,7 @@ readShelleyGenesis (File configPath) = liftIO $ do case Aeson.parseMaybe (Aeson.withObject "NodeConfig" (Aeson..: "ShelleyGenesisFile")) =<< mConfig of Nothing -> pure Nothing Just genesisPath -> Aeson.decodeFileStrict' $ takeDirectory configPath genesisPath - pure $ either (const Nothing) id result + pure $ fromRight Nothing result -- | Failure message explaining why a chain that stopped extending will never recover. -- See https://github.com/IntersectMBO/cardano-node/issues/5762 diff --git a/cardano-testnet/src/Testnet/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index 2f2213c63d7..0f10d7d16d6 100644 --- a/cardano-testnet/src/Testnet/Process/Run.hs +++ b/cardano-testnet/src/Testnet/Process/Run.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +#if !defined(mingw32_HOST_OS) +#define UNIX +#endif + module Testnet.Process.Run ( bashPath , execCli @@ -11,6 +17,7 @@ module Testnet.Process.Run , execCliStdoutToJson , execKESAgentControl , execKESAgentControl_ + , cleanupProcessBounded , initiateProcess , procCli , procNode @@ -25,6 +32,7 @@ module Testnet.Process.Run import Prelude +import Control.Concurrent (threadDelay) import Control.Exception (IOException) import Control.Monad import Control.Monad.Catch @@ -45,6 +53,10 @@ import qualified System.IO.Unsafe as IO import qualified System.Process as IO import System.Process +#ifdef UNIX +import System.Posix.Signals (sigKILL, signalProcess) +#endif + import Testnet.Process.RunIO (liftIOAnnotated) import Hedgehog (MonadTest) @@ -271,9 +283,45 @@ initiateProcess cp = do <- handlesExceptT resourceAndIOExceptionHandlers . liftIOAnnotated $ IO.createProcess cp releaseKey <- handlesExceptT resourceAndIOExceptionHandlers - . register $ IO.cleanupProcess (mhStdin, mhStdout, mhStderr, hProcess) + . register $ cleanupProcessBounded (mhStdin, mhStdout, mhStderr, hProcess) return (mhStdin, mhStdout, mhStderr, hProcess, releaseKey) +-- | Like 'IO.cleanupProcess', but with termination guaranteed (in bounded time): asks +-- the process to terminate, waits up to a grace period for it to exit, and escalates +-- to @SIGKILL@ - which a process cannot ignore or block, even while stopped - if it +-- did not. If the process still does not exit (e.g. it is stuck in an uninterruptible +-- kernel sleep), gives up and leaks it rather than blocking. +cleanupProcessBounded :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +cleanupProcessBounded (mStdin, mStdout, mStderr, hProcess) = do + IO.terminateProcess hProcess + forM_ [mStdin, mStdout, mStderr] . mapM_ $ \h -> + void (try (hClose h) :: IO (Either IOException ())) + terminated <- waitBounded terminateGracePeriodSeconds + unless terminated $ do +#ifdef UNIX + -- The process did not act on SIGTERM in time; SIGKILL cannot be ignored. + IO.getPid hProcess >>= mapM_ (signalProcess sigKILL) +#endif + -- On Windows 'IO.terminateProcess' is already a hard TerminateProcess() call, + -- so there is nothing to escalate to; just wait out the same grace period. + void $ waitBounded terminateGracePeriodSeconds + where + terminateGracePeriodSeconds :: Int + terminateGracePeriodSeconds = 15 + + -- Poll for process exit without ever blocking ('IO.getProcessExitCode' is + -- non-blocking, unlike 'IO.waitForProcess'). + waitBounded :: Int -> IO Bool + waitBounded seconds = go (seconds * 10) + where + go :: Int -> IO Bool + go n + | n <= 0 = pure False + | otherwise = + IO.getProcessExitCode hProcess >>= \case + Just _ -> pure True + Nothing -> threadDelay 100000 >> go (n - 1) + -- We can throw an IOException from createProcess or an ResourceCleanupException from the ResourceT monad resourceAndIOExceptionHandlers :: Applicative m => [Handler m ProcessError] resourceAndIOExceptionHandlers = [ Handler $ pure . ProcessIOException diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index e271f264d42..5e10478460b 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -51,6 +52,7 @@ import System.FilePath import qualified System.IO as IO import qualified System.Process as IO import System.Process (waitForProcess) +import System.Timeout (timeout) import Testnet.Filepath import Cardano.Node.Testnet.Paths (defaultSocketName) @@ -570,5 +572,10 @@ asyncRegister_ act = GHC.withFrozenCallStack $ do ) cleanUp where + -- 'H.cancel' waits for the cancelled thread to finish. Resource release actions + -- run with asynchronous exceptions masked, so if the thread does not act on the + -- cancellation (e.g. it is blocked in a foreign call), an unbounded wait here + -- would wedge the test run with no output and no way to interrupt it. Rather + -- leak the thread than block forever. cleanUp :: H.Async a -> IO () - cleanUp = H.cancel + cleanUp a = void . timeout 15_000_000 $ H.cancel a From 07d953ec99c343989d6906bac5e797a5a64a81a2 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Mon, 13 Jul 2026 20:07:20 +0000 Subject: [PATCH 3/3] cardano-testnet: replace per-wait stall detection with a chain-stall watchdog Detecting the irrecoverable chain stalls of #5762 inside individual wait primitives only helps tests that use those primitives: tests that wait by other means (raw `foldBlocks`/`foldEpochState` calls, `cardano-cli` polling loops) would still hang --- cardano-testnet/cardano-testnet.cabal | 1 + .../20260711_032508_palas_testnet_hang_fix.md | 3 +- cardano-testnet/src/Parsers/Cardano.hs | 11 +- cardano-testnet/src/Testnet/ChainWatchdog.hs | 177 ++++++++++++++++++ .../src/Testnet/Components/Query.hs | 149 +-------------- cardano-testnet/src/Testnet/Process/Run.hs | 20 +- cardano-testnet/src/Testnet/Start/Cardano.hs | 18 +- cardano-testnet/src/Testnet/Start/Types.hs | 6 + cardano-testnet/src/Testnet/Types.hs | 17 +- .../files/golden/help.cli | 1 + .../files/golden/help/cardano.cli | 5 + 11 files changed, 250 insertions(+), 158 deletions(-) create mode 100644 cardano-testnet/src/Testnet/ChainWatchdog.hs diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index f939a8be8d1..4ec241160c3 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -111,6 +111,7 @@ library exposed-modules: Cardano.Testnet Parsers.Run Testnet.Blockfrost + Testnet.ChainWatchdog Testnet.Components.Configuration Testnet.Components.Query Testnet.Defaults diff --git a/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md b/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md index 39ff0d6261a..29de4d5ad11 100644 --- a/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md +++ b/cardano-testnet/changelog.d/20260711_032508_palas_testnet_hang_fix.md @@ -1,5 +1,4 @@ ## Fixed -- Changed `retryUntilRightM` and `waitUntilEpoch` to fail if the chain dies. +- Add a chain-stall watchdog, on by default (`--disable-chain-stall-watchdog` or `runtimeEnableChainStallWatchdog` to opt out): when the chain stops producing blocks forever, every test now fails fast with a message explaining the mechanism, instead of hanging in whatever it was waiting on. - Make the timeout for testnet startup depend on the testnet config. - diff --git a/cardano-testnet/src/Parsers/Cardano.hs b/cardano-testnet/src/Parsers/Cardano.hs index eebbb436d71..eb86499e479 100644 --- a/cardano-testnet/src/Parsers/Cardano.hs +++ b/cardano-testnet/src/Parsers/Cardano.hs @@ -23,9 +23,9 @@ import Data.Word (Word64) import Options.Applicative (CommandFields, Mod, Parser) import qualified Options.Applicative as OA import Options.Applicative.Types (readerAsk) -import Text.Parsec (char, many1, noneOf, - sepBy1, string, try, (), parse, eof, notFollowedBy) import qualified Text.Parsec as Parsec +import Text.Parsec (char, eof, many1, noneOf, notFollowedBy, parse, sepBy1, string, try, + ()) import qualified Text.Parsec.String as Parsec import Testnet.Defaults (defaultEra) @@ -73,6 +73,7 @@ pRuntimeOptions = TestnetRuntimeOptions <$> pEnableNewEpochStateLogging <*> pEnableRpc <*> pKesSource + <*> pEnableChainStallWatchdog pScratchOutputDir :: Parser (Maybe FilePath) pScratchOutputDir = optional $ OA.strOption @@ -111,6 +112,12 @@ pKesSource = OA.flag UseKesKeyFile UseKesSocket <> OA.showDefault ) +pEnableChainStallWatchdog :: Parser Bool +pEnableChainStallWatchdog = OA.flag True False + ( OA.long "disable-chain-stall-watchdog" + <> OA.help "Disable the background watchdog that makes the run fail fast, with a diagnosis, when the chain stops producing blocks forever." + ) + pTestnetNodesWithOptions :: Parser TestnetNodesWithOptions pTestnetNodesWithOptions = pNodes <|> pNumPoolNodes <|> pure cardanoDefaultTestnetNodesWithOptions diff --git a/cardano-testnet/src/Testnet/ChainWatchdog.hs b/cardano-testnet/src/Testnet/ChainWatchdog.hs new file mode 100644 index 00000000000..41888af647f --- /dev/null +++ b/cardano-testnet/src/Testnet/ChainWatchdog.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | A background watchdog that fails the test as soon as the testnet chain has +-- provably stalled forever, whatever the test happens to be waiting on. +-- +-- A @cardano-testnet@ chain permanently stops producing blocks whenever no block is +-- forged for longer than the ledger view forecast horizon (see +-- 'chainForecastHorizon'). +module Testnet.ChainWatchdog + ( ChainStallException (..) + , chainForecastHorizon + , chainStallTimeoutFromHorizon + , chainStallWatchdog + ) where + +import Cardano.Api (BlockNo (..), ChainTip (..), LocalNodeConnectInfo, + ShelleyGenesis (..), SlotNo (..), getLocalChainTip) + +import qualified Cardano.Ledger.BaseTypes as SL +import qualified Cardano.Ledger.Shelley.Genesis as SL +import qualified Cardano.Ledger.Shelley.StabilityWindow as SL + +import Prelude + +import Control.Concurrent (ThreadId, threadDelay, throwTo) +import Control.Exception (Exception (..), SomeAsyncException, SomeException, + asyncExceptionFromException, asyncExceptionToException, throwIO, try) +import Control.Monad (void, when) +import Data.Maybe (isJust, isNothing) +import qualified Data.Time.Clock as DTC +import System.IO (hFlush, hPutStrLn, stderr) +import System.Process (ProcessHandle) +import System.Timeout (timeout) + +import Testnet.Process.Run (hardKillProcess) + +-- | Thrown to the test thread when the chain has irrecoverably stalled. Registered +-- as an asynchronous exception (like the exceptions of 'Control.Exception.AsyncException') +-- so that handlers for synchronous errors inside tests do not accidentally swallow it. +newtype ChainStallException = ChainStallException String + +instance Show ChainStallException where + show (ChainStallException msg) = msg + +instance Exception ChainStallException where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +-- | The ledger view forecast horizon of the chain described by the given genesis: +-- @3 * securityParam / activeSlotsCoeff@ slots (the stability window), converted to +-- wall-clock time. Nodes can only forge while the wall-clock slot is at most this far +-- past the chain tip, so a chain that has not forged for longer than this can never +-- produce a block again. +chainForecastHorizon :: ShelleyGenesis -> DTC.NominalDiffTime +chainForecastHorizon sg = + fromIntegral horizonSlots * SL.fromNominalDiffTimeMicro (sgSlotLength sg) + where + horizonSlots = + SL.computeStabilityWindow + (SL.unNonZero $ sgSecurityParam sg) + (SL.mkActiveSlotCoeff $ sgActiveSlotsCoeff sg) + +-- | Stall detection threshold for a chain with the given forecast horizon: twice the +-- horizon (a chain quiet for longer than the horizon is already irrecoverable; the +-- factor and the 60s floor absorb block-interval variance and detection latency). +chainStallTimeoutFromHorizon :: DTC.NominalDiffTime -> DTC.NominalDiffTime +chainStallTimeoutFromHorizon horizon = max 60 (2 * horizon) + +-- | Watch the chain through the given node connection and, when it has made no progress +-- for 'chainStallTimeoutFromHorizon' of the genesis, fail the given test thread with +-- a 'ChainStallException' explaining the mechanism. +-- +-- The full diagnosis is printed to stderr first: stderr bypasses tasty's buffered +-- reporting, so the explanation is visible even if the test never manages to report +-- a result. 'throwTo' blocks until the exception is delivered; if the test thread +-- cannot receive it (it is stuck in a foreign call or under +-- 'Control.Exception.uninterruptibleMask'), the watchdog escalates after a grace +-- period by hard-killing the node processes, so that whatever the test is blocked +-- on fails with an ordinary synchronous error instead. +-- +-- Run it in a background thread (e.g. with 'Testnet.Runtime.asyncRegister_'); it is +-- stopped by cancellation like any other background resource. +chainStallWatchdog + :: ShelleyGenesis -- ^ the genesis backing the testnet, for the stall threshold + -> LocalNodeConnectInfo -- ^ connection to the node whose chain tip is polled + -> [ProcessHandle] -- ^ the testnet node processes, for the kill escalation + -> ThreadId -- ^ the test thread to fail when the chain stalls + -> IO () +chainStallWatchdog shelleyGenesis connectInfo nodeHandles testThread = do + start <- DTC.getCurrentTime + go start Nothing + where + horizon = chainForecastHorizon shelleyGenesis + stallTimeout = chainStallTimeoutFromHorizon horizon + + go lastAdvance lastPoint = do + threadDelay pollIntervalMicros + mPoint <- queryTip + now <- DTC.getCurrentTime + case mPoint of + Just point | Just point /= lastPoint -> + -- the tip moved: restart the stall clock + go now (Just point) + _ | now `DTC.diffUTCTime` lastAdvance >= stallTimeout -> + reportStall lastPoint + | otherwise -> + go lastAdvance lastPoint + + -- One observation of the chain tip. 'Nothing' means nothing usable: the + -- query failed, timed out, or the tip is still at genesis. + -- + -- Exceptions from the query count as "no observation" rather than being + -- propagated: one failure proves nothing, and persistent failure keeps + -- the stall clock running until the stall timeout fires. The query has a + -- timeout of its own because an unresponsive node (e.g. starved of CPU) + -- can accept the connection and then never answer, which would block the + -- polling forever. + -- + -- Asynchronous exceptions are re-thrown: they are not query failures but + -- this thread being told to stop (cancellation from the test teardown). + queryTip :: IO (Maybe (SlotNo, BlockNo)) + queryTip = + (try (timeout queryTimeoutMicros (getLocalChainTip connectInfo)) + :: IO (Either SomeException (Maybe ChainTip))) >>= \case + Right (Just (ChainTip slotNo _ blockNo)) -> pure $ Just (slotNo, blockNo) + Right (Just ChainTipAtGenesis) -> pure Nothing + Right Nothing -> pure Nothing + Left e + | isJust (fromException e :: Maybe SomeAsyncException) -> throwIO e + | otherwise -> pure Nothing + + reportStall lastPoint = do + let msg = chainStallFailureMessage stallTimeout horizon lastPoint + exc = ChainStallException msg + hPutStrLn stderr msg + hFlush stderr + delivered <- timeout deliveryGraceMicros $ throwTo testThread exc + when (isNothing delivered) $ do + hPutStrLn stderr $ + "chainStallWatchdog: could not deliver the failure to the test thread within " + <> show (deliveryGraceMicros `div` 1_000_000) <> "s (it is likely stuck in a foreign " + <> "call or under uninterruptibleMask, where asynchronous exceptions cannot be " + <> "received); killing the testnet nodes so that whatever it is blocked on fails instead." + hFlush stderr + mapM_ hardKillProcess nodeHandles + -- with the nodes dead the test thread should unblock shortly; try once more to + -- attach the real explanation to the test failure + void . timeout deliveryGraceMicros $ throwTo testThread exc + + pollIntervalMicros, queryTimeoutMicros, deliveryGraceMicros :: Int + pollIntervalMicros = 5_000_000 + queryTimeoutMicros = 5_000_000 + deliveryGraceMicros = 15_000_000 + +-- | Failure message explaining why a chain that stopped extending will never recover. +-- See https://github.com/IntersectMBO/cardano-node/issues/5762 +chainStallFailureMessage + :: DTC.NominalDiffTime -- ^ the stall-detection timeout that expired + -> DTC.NominalDiffTime -- ^ the chain's forecast horizon + -> Maybe (SlotNo, BlockNo) -- ^ last observed chain tip, if any + -> String +chainStallFailureMessage stallTimeout horizon lastPoint = + unlines + [ "The testnet chain made no progress for " <> show stallTimeout <> "." + , case lastPoint of + Just (SlotNo slotNo, BlockNo blockNo) -> + "Last observed chain state: slot " <> show slotNo <> ", block " <> show blockNo <> "." + Nothing -> "No chain state update was observed at all." + , "The network is almost certainly stalled forever: nodes can only forge when the wall-clock" + , "slot is at most 3 * securityParam / activeSlotsCoeff slots past the chain tip - the ledger" + , "view forecast horizon, which is " <> show horizon <> " of wall clock for this testnet." + , "Once no block was forged for longer than that - e.g. because node startup took too long or" + , "the machine was too overloaded to produce a block in time - every node fails its leadership" + , "checks and the chain can never extend again, so we fail fast instead of" + , "hanging." + ] diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 9d56316d112..8f085bd662f 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -23,7 +23,6 @@ module Testnet.Components.Query , getTreasuryValue , TestnetWaitPeriod (..) - , chainForecastHorizon , waitForEpochs , waitUntilEpoch , waitForBlocks @@ -54,24 +53,19 @@ import qualified Cardano.Api.UTxO as Utxo import Cardano.Ledger.Api (ConwayGovState) import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Api.State.Query as SQ -import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Conway.Governance as L import qualified Cardano.Ledger.Conway.PParams as L -import qualified Cardano.Ledger.Shelley.Genesis as SL import qualified Cardano.Ledger.Shelley.LedgerState as L -import qualified Cardano.Ledger.Shelley.StabilityWindow as SL import qualified Cardano.Ledger.State as L import Prelude import Control.Applicative ((<|>)) -import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM, TVar, modifyTVar', newTVarIO, readTVar, writeTVar) import qualified Control.Concurrent.STM as STM import Control.Monad import Control.Monad.Trans.Maybe (MaybeT (..), mapMaybeT, runMaybeT) import Control.Monad.Trans.Resource -import Data.Either (fromRight) import Data.List (sortOn) import qualified Data.Map as Map import Data.Map.Strict (Map) @@ -79,17 +73,12 @@ import Data.Maybe import Data.Ord (Down (..)) import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Time.Clock as DTC import Data.Type.Equality import Data.Word (Word64) import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro (Lens', to, (^.)) -import System.FilePath (takeDirectory, ()) -import System.IO.Error (tryIOError) import Testnet.Process.RunIO (liftIOAnnotated) import Testnet.Property.Assert @@ -101,7 +90,6 @@ import qualified Hedgehog as H import Hedgehog.Extras (MonadAssertion) import qualified Hedgehog.Extras as H -import UnliftIO.Async (race) import UnliftIO.STM (atomically, readTVarIO, registerDelay) -- | Block and wait for the desired epoch. @@ -114,31 +102,16 @@ waitUntilEpoch -> EpochNo -- ^ Desired epoch -> m EpochNo -- ^ The epoch number reached waitUntilEpoch nodeConfigFile socketPath desiredEpoch = withFrozenCallStack $ do - mHorizon <- fmap chainForecastHorizon <$> readShelleyGenesis nodeConfigFile - let stallTimeout = maybe fallbackChainStallTimeout chainStallTimeoutFromHorizon mHorizon - lastProgress <- H.evalIO $ do - now <- DTC.getCurrentTime - newIORef (now, Nothing) - result <- H.evalIO $ - race (chainStallWatchdog stallTimeout lastProgress) $ - runExceptT $ - foldEpochState nodeConfigFile socketPath QuickValidation desiredEpoch () $ - \_ slotNo blockNo -> do - liftIO $ do - now <- DTC.getCurrentTime - writeIORef lastProgress (now, Just (slotNo, blockNo)) - pure ConditionNotMet + result <- H.evalIO . runExceptT $ + foldEpochState + nodeConfigFile socketPath QuickValidation desiredEpoch () (\_ _ _ -> pure ConditionNotMet) case result of - Left lastPoint -> do - H.note_ $ chainStallFailureMessage stallTimeout mHorizon - ("waiting for " <> show desiredEpoch) lastPoint - H.failure - Right (Left (FoldBlocksApplyBlockError (TerminationEpochReached epochNo))) -> + Left (FoldBlocksApplyBlockError (TerminationEpochReached epochNo)) -> pure epochNo - Right (Left err) -> do + Left err -> do H.note_ $ "waitUntilEpoch: could not reach termination epoch, " <> docToString (prettyError err) H.failure - Right (Right res) -> do + Right res -> do H.note_ $ "waitUntilEpoch: could not reach termination epoch - no error returned " <> "- invalid foldEpochState behaviour, result: " <> show res H.failure @@ -212,106 +185,13 @@ retryUntilRightM esv timeout act = withFrozenCallStack $ do cv <- getCurrentValue if cv > deadline then pure l - else - awaitStateUpdateTimeout esv (epochStallTimeout esv) versionBeforeAct >>= \case - Just _ -> go deadline - Nothing -> do - -- No chain-state update for the whole fallback window: the chain has - -- stopped extending and can never recover. Fail instead of looping forever. - lastState <- readTVarIO $ epochStateView esv - let lastPoint = either (const Nothing) (\(_, s, b) -> Just (s, b)) lastState - H.note_ $ chainStallFailureMessage (epochStallTimeout esv) (epochStallHorizon esv) - ("waiting for " <> show timeout) lastPoint - H.failure + else awaitStateUpdateTimeout esv 300 versionBeforeAct *> go deadline (getCurrentValue, timeoutW64) = case timeout of WaitForEpochs (EpochInterval n) -> (unEpochNo <$> getCurrentEpochNo esv, fromIntegral n) WaitForSlots n -> (unSlotNo <$> getSlotNumber esv, n) WaitForBlocks n -> (unBlockNo <$> getBlockNumber esv, n) --- | How long a testnet chain may go without any new block before we conclude it is --- permanently stalled, when the genesis backing the testnet cannot be read to compute --- 'chainStallTimeoutFromHorizon'. Deliberately conservative: an order of magnitude --- above the forecast horizon of the default genesis options. -fallbackChainStallTimeout :: DTC.NominalDiffTime -fallbackChainStallTimeout = 300 - --- | The ledger view forecast horizon of the chain described by the given genesis: --- @3 * securityParam / activeSlotsCoeff@ slots (the stability window), converted to --- wall-clock time. Nodes can only forge while the wall-clock slot is at most this far --- past the chain tip, so a chain that has not forged for longer than this can never --- produce a block again: every node fails its leadership checks with --- @Forge.Loop.NoLedgerView@. See https://github.com/IntersectMBO/cardano-node/issues/5762 -chainForecastHorizon :: ShelleyGenesis -> DTC.NominalDiffTime -chainForecastHorizon sg = - fromIntegral horizonSlots * SL.fromNominalDiffTimeMicro (sgSlotLength sg) - where - horizonSlots = - SL.computeStabilityWindow - (SL.unNonZero $ sgSecurityParam sg) - (SL.mkActiveSlotCoeff $ sgActiveSlotsCoeff sg) - --- | Stall detection threshold for a chain with the given forecast horizon: twice the --- horizon (a chain quiet for longer than the horizon is already irrecoverable; the --- factor and the 60s floor absorb block-interval variance and detection latency). -chainStallTimeoutFromHorizon :: DTC.NominalDiffTime -> DTC.NominalDiffTime -chainStallTimeoutFromHorizon horizon = max 60 (2 * horizon) - --- | Best-effort read of the Shelley genesis backing a node configuration: looks up the --- @ShelleyGenesisFile@ key in the (JSON) node configuration, resolves it relative to the --- configuration file's directory, and decodes the genesis. Returns 'Nothing' whenever --- anything cannot be read, so callers can fall back to conservative defaults. -readShelleyGenesis :: MonadIO m => NodeConfigFile In -> m (Maybe ShelleyGenesis) -readShelleyGenesis (File configPath) = liftIO $ do - result <- tryIOError $ do - mConfig <- Aeson.decodeFileStrict' configPath - case Aeson.parseMaybe (Aeson.withObject "NodeConfig" (Aeson..: "ShelleyGenesisFile")) =<< mConfig of - Nothing -> pure Nothing - Just genesisPath -> Aeson.decodeFileStrict' $ takeDirectory configPath genesisPath - pure $ fromRight Nothing result - --- | Failure message explaining why a chain that stopped extending will never recover. --- See https://github.com/IntersectMBO/cardano-node/issues/5762 -chainStallFailureMessage - :: DTC.NominalDiffTime -- ^ the stall-detection timeout that expired - -> Maybe DTC.NominalDiffTime -- ^ the chain's forecast horizon, when known - -> String -- ^ what we were waiting for - -> Maybe (SlotNo, BlockNo) -- ^ last observed chain state, if any - -> String -chainStallFailureMessage stallTimeout mHorizon while lastPoint = - unlines - [ "The testnet chain made no progress for " <> show stallTimeout <> " while " <> while <> "." - , case lastPoint of - Just (SlotNo slotNo, BlockNo blockNo) -> - "Last observed chain state: slot " <> show slotNo <> ", block " <> show blockNo <> "." - Nothing -> "No chain state update was observed at all." - , "The network is almost certainly stalled forever: nodes can only forge when the wall-clock" - , "slot is at most 3 * securityParam / activeSlotsCoeff slots past the chain tip - the ledger" - , "view forecast horizon, which is " <> horizonStr <> " of wall clock for this testnet." - , "Once no block was forged for longer than that - e.g. because node startup took too long or" - , "the machine was too overloaded to produce a block in time - every node fails its leadership" - , "checks and the chain can never extend again, so we fail fast instead of" - , "hanging." - ] - where - horizonStr = maybe "30s with the default genesis options" show mHorizon - --- | Completes when the point tracked by the given 'IORef' has not moved for the given --- stall timeout, returning the last observed point. -chainStallWatchdog - :: DTC.NominalDiffTime -- ^ stall timeout - -> IORef (DTC.UTCTime, Maybe (SlotNo, BlockNo)) - -> IO (Maybe (SlotNo, BlockNo)) -chainStallWatchdog stallTimeout lastProgress = go - where - go = do - threadDelay 5_000_000 - (lastUpdate, lastPoint) <- readIORef lastProgress - now <- DTC.getCurrentTime - if now `DTC.diffUTCTime` lastUpdate >= stallTimeout - then pure lastPoint - else go - -- | Retries the action until it returns 'Just' or the timeout is reached retryUntilJustM :: HasCallStack @@ -367,14 +247,6 @@ data EpochStateView = EpochStateView , epochStateVersion :: !(TVar Word64) -- ^ Monotonically increasing counter, bumped on every state write. -- Used by 'awaitStateUpdateTimeout' to block until the next update. - , epochStallTimeout :: !DTC.NominalDiffTime - -- ^ How long the chain may go without any new block before it is considered - -- irrecoverably stalled. Derived from the genesis backing the testnet in - -- 'getEpochStateView' (see 'chainStallTimeoutFromHorizon'), or - -- 'fallbackChainStallTimeout' when the genesis could not be read. - , epochStallHorizon :: !(Maybe DTC.NominalDiffTime) - -- ^ The ledger view forecast horizon of the chain ('chainForecastHorizon'), - -- when the genesis backing the testnet could be read. Used for diagnostics. } -- | Write a new value to the epoch state and bump the version counter atomically. @@ -514,12 +386,7 @@ getEpochStateView -> SocketPath -- ^ node socket path -> m EpochStateView getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do - mHorizon <- fmap chainForecastHorizon <$> readShelleyGenesis nodeConfigFile - esv <- H.evalIO $ EpochStateView - <$> newTVarIO (Left EpochStateNotInitialised) - <*> newTVarIO 0 - <*> pure (maybe fallbackChainStallTimeout chainStallTimeoutFromHorizon mHorizon) - <*> pure mHorizon + esv <- H.evalIO $ EpochStateView <$> newTVarIO (Left EpochStateNotInitialised) <*> newTVarIO 0 _ <- asyncRegister_ $ do result <- runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) () $ \epochState slotNumber blockNumber -> do diff --git a/cardano-testnet/src/Testnet/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index 0f10d7d16d6..fa25a85d8e0 100644 --- a/cardano-testnet/src/Testnet/Process/Run.hs +++ b/cardano-testnet/src/Testnet/Process/Run.hs @@ -18,6 +18,7 @@ module Testnet.Process.Run , execKESAgentControl , execKESAgentControl_ , cleanupProcessBounded + , hardKillProcess , initiateProcess , procCli , procNode @@ -298,12 +299,8 @@ cleanupProcessBounded (mStdin, mStdout, mStderr, hProcess) = do void (try (hClose h) :: IO (Either IOException ())) terminated <- waitBounded terminateGracePeriodSeconds unless terminated $ do -#ifdef UNIX - -- The process did not act on SIGTERM in time; SIGKILL cannot be ignored. - IO.getPid hProcess >>= mapM_ (signalProcess sigKILL) -#endif - -- On Windows 'IO.terminateProcess' is already a hard TerminateProcess() call, - -- so there is nothing to escalate to; just wait out the same grace period. + -- The process did not act on SIGTERM in time; escalate to an unignorable kill. + hardKillProcess hProcess void $ waitBounded terminateGracePeriodSeconds where terminateGracePeriodSeconds :: Int @@ -322,6 +319,17 @@ cleanupProcessBounded (mStdin, mStdout, mStderr, hProcess) = do Just _ -> pure True Nothing -> threadDelay 100000 >> go (n - 1) +-- | Send an unignorable kill to the process: @SIGKILL@ on unix, which cannot be +-- ignored or blocked, even by a stopped process. On Windows 'IO.terminateProcess' +-- is already a hard TerminateProcess() call that cannot be refused, so it is used +-- directly. +hardKillProcess :: ProcessHandle -> IO () +#ifdef UNIX +hardKillProcess hProcess = IO.getPid hProcess >>= mapM_ (signalProcess sigKILL) +#else +hardKillProcess = IO.terminateProcess +#endif + -- We can throw an IOException from createProcess or an ResourceCleanupException from the ResourceT monad resourceAndIOExceptionHandlers :: Applicative m => [Handler m ProcessError] resourceAndIOExceptionHandlers = [ Handler $ pure . ProcessIOException diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index a7eeee86c34..d00c349601f 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -47,7 +47,7 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPo import Prelude hiding (lines) -import Control.Concurrent (threadDelay) +import Control.Concurrent (myThreadId, threadDelay) import Control.Monad (forM, forM_, guard, unless, when) import Control.Monad.Trans.Maybe (runMaybeT) import Control.Exception (IOException) @@ -74,8 +74,8 @@ import qualified System.Directory as IO import qualified System.Process as Process import System.FilePath (()) +import Testnet.ChainWatchdog (chainForecastHorizon, chainStallWatchdog) import Testnet.Components.Configuration -import Testnet.Components.Query (chainForecastHorizon) import qualified Testnet.Defaults as Defaults import Cardano.Node.Testnet.Paths (defaultConfigFile, defaultNodeEnvFile, defaultPortFile, defaultUtxoAddrPath) @@ -249,6 +249,7 @@ cardanoTestnet { runtimeEnableNewEpochStateLogging=enableNewEpochStateLogging , runtimeEnableRpc=cardanoEnableRpc , runtimeKESSource=cardanoKESSource + , runtimeEnableChainStallWatchdog=enableChainStallWatchdog } Conf { tempAbsPath=TmpAbsolutePath tmpAbsPath @@ -401,6 +402,19 @@ cardanoTestnet , delegators = [] } + -- The chain can also stall irrecoverably later, at any point of the test, if an + -- overloaded machine starves the nodes of CPU for longer than the forecast horizon. + -- So watch the chain in the background and fail the test with a diagnosis + -- as soon as a stall is provable. + when enableChainStallWatchdog $ do + testThread <- liftIOAnnotated myThreadId + watchedNode <- case uncons testnetNodes' of + Just (node, _) -> pure node + Nothing -> throwString "cardanoTestnet: no testnet node to watch for chain stalls" + void . asyncRegister_ $ + chainStallWatchdog shelleyGenesis (testnetNodeConnectionInfo testnetMagic watchedNode) + (nodeProcessHandle <$> testnetNodes') testThread + let tempBaseAbsPath = makeTmpBaseAbsPath $ TmpAbsolutePath tmpAbsPath node1sprocket <- case uncons $ testnetSprockets runtime of diff --git a/cardano-testnet/src/Testnet/Start/Types.hs b/cardano-testnet/src/Testnet/Start/Types.hs index 2d92d76554d..aee356be2cd 100644 --- a/cardano-testnet/src/Testnet/Start/Types.hs +++ b/cardano-testnet/src/Testnet/Start/Types.hs @@ -202,6 +202,11 @@ data TestnetRuntimeOptions = TestnetRuntimeOptions { runtimeEnableNewEpochStateLogging :: Bool -- ^ if epoch state logging is enabled , runtimeEnableRpc :: RpcSupport -- ^ Whether to enable gRPC endpoints in all testnet nodes , runtimeKESSource :: PraosCredentialsSource + , runtimeEnableChainStallWatchdog :: Bool + -- ^ Whether to run a background watchdog that fails the test with a diagnosis as + -- soon as the chain has provably stopped producing blocks forever (see + -- "Testnet.ChainWatchdog"). On by default; disable it only for tests that + -- legitimately halt all block production. } deriving (Eq, Show) instance Default TestnetRuntimeOptions where @@ -209,6 +214,7 @@ instance Default TestnetRuntimeOptions where { runtimeEnableNewEpochStateLogging = True , runtimeEnableRpc = RpcDisabled , runtimeKESSource = def + , runtimeEnableChainStallWatchdog = True } -- | Options specific to the @--node-env@ path: the environment directory diff --git a/cardano-testnet/src/Testnet/Types.hs b/cardano-testnet/src/Testnet/Types.hs index 150087cd361..2501d4a065c 100644 --- a/cardano-testnet/src/Testnet/Types.hs +++ b/cardano-testnet/src/Testnet/Types.hs @@ -23,6 +23,7 @@ module Testnet.Types , nodeSocketPath , nodeRpcSocketPath , nodeConnectionInfo + , testnetNodeConnectionInfo , isTestnetNodeSpo , SpoNodeKeys(..) , Delegator(..) @@ -176,11 +177,17 @@ nodeConnectionInfo TestnetRuntime{testnetMagic, testnetNodes} index = Nothing -> do H.note_ $ "There is no node in the testnet with index: " <> show index <> ". Number of nodes: " <> show (length testnetNodes) H.failure - Just node -> - pure LocalNodeConnectInfo - { localNodeSocketPath= nodeSocketPath node - , localNodeNetworkId=Testnet (NetworkMagic $ fromIntegral testnetMagic) - , localConsensusModeParams=CardanoModeParams $ EpochSlots 21600} + Just node -> pure $ testnetNodeConnectionInfo testnetMagic node + +-- | Connection data for the given node of a testnet with the given magic +testnetNodeConnectionInfo :: Int -- ^ testnet magic + -> TestnetNode + -> LocalNodeConnectInfo +testnetNodeConnectionInfo testnetMagic node = + LocalNodeConnectInfo + { localNodeSocketPath= nodeSocketPath node + , localNodeNetworkId=Testnet (NetworkMagic $ fromIntegral testnetMagic) + , localConsensusModeParams=CardanoModeParams $ EpochSlots 21600} data SpoNodeKeys = SpoNodeKeys diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli index 727d84e5bb3..60d6619ae13 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli @@ -15,6 +15,7 @@ Usage: cardano-testnet cardano [--enable-new-epoch-state-logging] [--enable-grpc] [--use-kes-agent] + [--disable-chain-stall-watchdog] Start a testnet and keep it running until stopped diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli index cad989c099a..b794b592385 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli @@ -13,6 +13,7 @@ Usage: cardano-testnet cardano [--enable-new-epoch-state-logging] [--enable-grpc] [--use-kes-agent] + [--disable-chain-stall-watchdog] Start a testnet and keep it running until stopped @@ -61,4 +62,8 @@ Available options: directory as node's N2C socket. --use-kes-agent Get Praos block forging credentials from kes-agent via the default socket path + --disable-chain-stall-watchdog + Disable the background watchdog that makes the run + fail fast, with a diagnosis, when the chain stops + producing blocks forever. -h,--help Show this help text