cardano-testnet | Wait for blocks using foldEpochState instead of filtering logs

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)

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