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..9d56316d112 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,19 +54,24 @@ 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) @@ -73,12 +79,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 +101,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 +114,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 +212,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 $ 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 @@ -247,6 +367,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 +514,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/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index 2f2213c63d7..e2bcb66dbe7 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,53 @@ 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. +-- +-- 'IO.cleanupProcess' only sends @SIGTERM@ and then waits for the process in a +-- fire-and-forget background thread, so a process that does not act on the +-- termination request - e.g. one starved of CPU on an overloaded CI machine, or one +-- for which the signal stays pending (macOS keeps fatal signals pending on stopped +-- processes) - silently survives the cleanup. Each such leaked node keeps consuming +-- resources, starving the machine further. See the CI-timeout flavour of +-- https://github.com/IntersectMBO/cardano-node/issues/5762 +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 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 :: ()