diff --git a/cardano-testnet/src/Testnet/Property/Assert.hs b/cardano-testnet/src/Testnet/Property/Assert.hs index 800eb927884..f0c68fba937 100644 --- a/cardano-testnet/src/Testnet/Property/Assert.hs +++ b/cardano-testnet/src/Testnet/Property/Assert.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -10,7 +9,6 @@ module Testnet.Property.Assert ( assertByDeadlineIOCustom , readJsonLines - , assertChainExtended , getRelevantSlots , assertExpectedSposInLedgerState , assertErasEqual @@ -39,31 +37,24 @@ import qualified Data.Time.Clock as DTC import Data.Type.Equality import Data.Word (Word8) import GHC.Stack as GHC -import RIO (throwString) import Testnet.Process.RunIO import Testnet.Start.Types -import Testnet.Types import Hedgehog (MonadTest) import qualified Hedgehog as H +import qualified Hedgehog.Extras as H import Hedgehog.Extras.Internal.Test.Integration (IntegrationState) -import qualified Hedgehog.Extras.Stock.IO.File as IO -import qualified Hedgehog.Extras.Test.Base as H import Hedgehog.Extras.Test.Process (ExecConfig) +import RIO (throwString) + newlineBytes :: Word8 newlineBytes = 10 readJsonLines :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m [Value] readJsonLines fp = withFrozenCallStack $ mapMaybe (Aeson.decode @Value) . LBS.split newlineBytes <$> H.evalIO (LBS.readFile fp) -fileJsonGrep :: FilePath -> (Value -> Bool) -> IO Bool -fileJsonGrep fp f = do - lines <- LBS.split newlineBytes <$> LBS.readFile fp - let jsons = mapMaybe (Aeson.decode @Value) lines - return $ L.any f jsons - assertByDeadlineIOCustom :: (MonadIO m, HasCallStack) => String -> DTC.UTCTime -> IO Bool -> m () @@ -94,31 +85,17 @@ assertExpectedSposInLedgerState output (NumPools numExpectedPools) execConfig = ePoolSet <- liftIOAnnotated (Aeson.eitherDecodeFileStrict' @(Set PoolId) output) case ePoolSet of - Left err -> + Left err -> throwString $ "Failed to decode stake pools from ledger state: " <> err Right poolSet -> do let numPoolsInLedgerState = Set.size poolSet unless (numPoolsInLedgerState == numExpectedPools) $ - throwString $ unlines + throwString $ unlines [ "Expected number of stake pools not found in ledger state" , "Expected: ", show numExpectedPools , "Actual: ", show numPoolsInLedgerState ] -assertChainExtended - :: HasCallStack - => MonadIO m - => DTC.UTCTime - -> NodeLoggingFormat - -> TestnetNode - -> m () -assertChainExtended deadline nodeLoggingFormat TestnetNode{nodeName, nodeStdout} = withFrozenCallStack $ - assertByDeadlineIOCustom ("Chain not extended in " <> nodeName) deadline $ do - case nodeLoggingFormat of - NodeLoggingFormatAsText -> IO.fileContains "Chain extended, new tip" nodeStdout - NodeLoggingFormatAsJson -> fileJsonGrep nodeStdout $ \v -> - Aeson.parseMaybe (Aeson.parseJSON @(LogEntry Kind)) v == Just (LogEntry (Kind "AddedToCurrentChain")) - newtype LogEntry a = LogEntry { unLogEntry :: a } deriving (Eq, Show) diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index ebc68247503..32ad32e1747 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -65,7 +65,7 @@ import Testnet.Filepath import Testnet.Handlers (interruptNodesOnSigINT) import Testnet.Orphans () import Testnet.Process.RunIO (execCli', execCli_, liftIOAnnotated, mkExecConfig) -import Testnet.Property.Assert (assertChainExtended, assertExpectedSposInLedgerState) +import Testnet.Property.Assert (assertExpectedSposInLedgerState) import Testnet.Runtime as TR import Testnet.Start.Types import Testnet.Types as TR hiding (shelleyGenesis) @@ -74,8 +74,9 @@ import qualified Hedgehog.Extras as H import qualified Hedgehog.Extras.Stock.IO.Network.Port as H import Hedgehog.Internal.Property (failException) -import RIO (MonadUnliftIO, RIO (..), runRIO, throwString) +import RIO (MonadUnliftIO, RIO (..), runRIO, throwString, timeout) import RIO.Orphans (ResourceMap) +import RIO.State (put) import UnliftIO.Async import UnliftIO.Exception (stringException) @@ -226,8 +227,7 @@ cardanoTestnet , updateTimestamps } = do let CardanoTestnetOptions - { cardanoNodeLoggingFormat=nodeLoggingFormat - , cardanoEnableNewEpochStateLogging=enableNewEpochStateLogging + { cardanoEnableNewEpochStateLogging=enableNewEpochStateLogging , cardanoNodes } = testnetOptions nPools = cardanoNumPools testnetOptions @@ -282,7 +282,7 @@ cardanoTestnet liftIOAnnotated $ writeFile (nodeDataDir "port") (show portNumber) let topologyPath = tmpAbsPath Defaults.defaultNodeDataDir i "topology.json" tBytes <- liftIOAnnotated $ LBS.readFile topologyPath - case eitherDecode tBytes of + case eitherDecode tBytes of Right (abstractTopology :: P2P.NetworkTopology NodeId) -> do topology <- mapM idToRemoteAddressP2P abstractTopology liftIOAnnotated $ LBS.writeFile topologyPath $ encode topology @@ -349,11 +349,8 @@ cardanoTestnet -- Interrupt cardano nodes when the main process is interrupted liftIOAnnotated $ interruptNodesOnSigINT testnetNodes' - -- FIXME: use foldEpochState waiting for chain extensions - now <- liftIOAnnotated DTC.getCurrentTime - let deadline = DTC.addUTCTime 45 now - forM_ testnetNodes' $ \nodeStdoutFile -> do - assertChainExtended deadline nodeLoggingFormat nodeStdoutFile + -- Make sure that all nodes are healthy by waiting for a chain extension + mapConcurrently_ (waitForBlockThrow 45 (File nodeConfigFile)) testnetNodes' let runtime = TestnetRuntime { configurationFile = File nodeConfigFile @@ -397,6 +394,37 @@ cardanoTestnet mkTestnetNodeKeyPaths :: Int -> SpoNodeKeys mkTestnetNodeKeyPaths n = makePathsAbsolute $ Defaults.defaultSpoKeys n + -- 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 + -> NodeConfigFile 'In + -> TestnetNode + -> m () + waitForBlockThrow timeoutSeconds nodeConfigFile node@TestnetNode{nodeName} = do + result <- timeout (timeoutSeconds * 1_000_000) $ + runExceptT . foldEpochState + nodeConfigFile + (nodeSocketPath node) + QuickValidation + (EpochNo maxBound) + minBound + $ \_ slotNo blockNo -> do + put slotNo + pure $ if blockNo >= 1 + then ConditionMet -- we got one block + else ConditionNotMet + + case result of + Just (Right (ConditionMet, _)) -> pure () + Just (Right (ConditionNotMet, slotNo)) -> + throwString $ nodeName <> " was unable to produce any blocks. Reached slot " <> show slotNo + 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" + + -- | A convenience wrapper around `createTestnetEnv` and `cardanoTestnet` createAndRunTestnet :: () => HasCallStack @@ -420,8 +448,8 @@ retryOnAddressInUseError retryOnAddressInUseError act = withFrozenCallStack $ go maximumTimeout retryTimeout where go :: HasCallStack => NominalDiffTime -> NominalDiffTime -> ExceptT NodeStartFailure m a - go timeout interval - | timeout <= 0 = withFrozenCallStack $ do + go timeout' interval + | timeout' <= 0 = withFrozenCallStack $ do act | otherwise = withFrozenCallStack $ do !time <- liftIOAnnotated DTC.getCurrentTime @@ -430,7 +458,7 @@ retryOnAddressInUseError act = withFrozenCallStack $ go maximumTimeout retryTime liftIOAnnotated $ threadDelay (round $ interval * 1_000_000) !time' <- liftIOAnnotated DTC.getCurrentTime let elapsedTime = time' `diffUTCTime` time - newTimeout = timeout - elapsedTime + newTimeout = timeout' - elapsedTime go newTimeout interval e -> throwError e