Reenable DRep Activity and fixes for stability

cardano-testnet/src/Testnet/Components/Query.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -20,6 +21,7 @@ module Testnet.Components.Query
   , findLargestUtxoWithAddress
   , findLargestUtxoForPaymentKey
   , startLedgerNewEpochStateLogging
+  , watchEpochStateView
   ) where
 
 import           Cardano.Api as Api
@@ -48,6 +50,7 @@ import           Data.Ord (Down (..))
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Type.Equality
+import           Data.Word (Word64)
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
 import           Lens.Micro (to, (^.))
@@ -128,7 +131,7 @@ getEpochStateView
 getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do
   epochStateView <- H.evalIO $ newIORef Nothing
   runInBackground . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing
-    $ \epochState _slotNb _blockNb -> do
+    $ \epochState _EpochNb _blockNb -> do
         liftIO $ writeIORef epochStateView (Just epochState)
         pure ConditionNotMet
   pure $ EpochStateView nodeConfigFile socketPath epochStateView
@@ -240,7 +243,7 @@ checkDRepsNumber epochStateView sbe expectedDRepsNumber = withFrozenCallStack $
 
 -- | @checkDRepState sbe configurationFile socketPath execConfig f@
 -- This functions helps check properties about the DRep state.
--- It waits up to two epochs for the result of applying @f@ to the DRepState
+-- It waits up to three epochs for the result of applying @f@ to the DRepState
 -- to become 'Just'. If @f@ keeps returning 'Nothing' the test fails.
 -- If @f@ returns 'Just', the contents of the 'Just' are returned.
 checkDRepState
@@ -257,9 +260,9 @@ checkDRepState
   -> m a
 checkDRepState epochStateView@EpochStateView{nodeConfigPath, socketPath} sbe f = withFrozenCallStack $ do
   currentEpoch <- getCurrentEpochNo epochStateView
-  let terminationEpoch = succ . succ $ currentEpoch
-  result <- H.evalIO . runExceptT $ foldEpochState nodeConfigPath socketPath QuickValidation terminationEpoch Nothing
-      $ \(AnyNewEpochState actualEra newEpochState) _slotNb _blockNb -> do
+  let terminationEpoch = succ . succ . succ $ currentEpoch
+  result <- H.evalIO . runExceptT $ foldEpochState nodeConfigPath socketPath FullValidation terminationEpoch Nothing
+      $ \(AnyNewEpochState actualEra newEpochState) _EpochNb _blockNb -> do
         Refl <- either error pure $ assertErasEqual sbe actualEra
         let dreps = shelleyBasedEraConstraints sbe newEpochState
                       ^. L.nesEsL
@@ -337,3 +340,32 @@ getCurrentEpochNo
 getCurrentEpochNo epochStateView = withFrozenCallStack $ do
   AnyNewEpochState _ newEpochState <- getEpochState epochStateView
   pure $ newEpochState ^. L.nesELL
+
+watchEpochStateView
+  :: forall m a. (MonadIO m, MonadTest m, MonadAssertion m, HasCallStack)
+  => EpochStateView
+  -> (AnyNewEpochState -> m (Maybe a))
+  -> Word64
+  -> Word64
+  -> m a
+watchEpochStateView epochStateView f minWait maxWait = do
+  AnyNewEpochState _ newEpochState <- getEpochState epochStateView
+  let (EpochNo currentEpoch) = L.nesEL newEpochState
+  go (EpochNo $ currentEpoch + minWait) (EpochNo $ currentEpoch + maxWait)
+    where
+      go :: EpochNo -> EpochNo -> m a
+      go (EpochNo startEpoch) (EpochNo timeout) = do
+        epochState@(AnyNewEpochState _ newEpochState') <- getEpochState epochStateView
+        let (EpochNo currentEpoch) = L.nesEL newEpochState'
+        if currentEpoch < startEpoch
+        then do H.threadDelay 100_000
+                go (EpochNo startEpoch) (EpochNo timeout)
+        else do condition <- f epochState
+                case condition of
+                  Just result -> pure result
+                  Nothing ->
+                    if currentEpoch > timeout
+                    then H.failMessage callStack $ "foldEpochStateView reached timeout: " <> show timeout
+                    else do H.threadDelay 100_000
+                            go (EpochNo startEpoch) (EpochNo timeout)
+

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepActivity.hs

@@ -15,15 +15,13 @@ import           Cardano.Api.Ledger (EpochInterval (EpochInterval), drepExpiry)
 
 import           Cardano.Ledger.Conway.Core (curPParamsGovStateL)
 import           Cardano.Ledger.Conway.PParams (ppDRepActivityL)
-import           Cardano.Ledger.Shelley.API (NewEpochState (..))
 import           Cardano.Ledger.Shelley.LedgerState (epochStateGovStateL, nesEpochStateL)
 import           Cardano.Testnet
 
 import           Prelude
 
 import           Control.Monad
 import           Control.Monad.Catch (MonadCatch)
-import           Control.Monad.Trans.State.Strict (StateT)
 import qualified Data.Map as Map
 import           Data.String
 import qualified Data.Text as Text
@@ -37,7 +35,7 @@ import           Testnet.Components.DReps (createVotingTxBody, delegateToDRep, g
                    submitTx)
 import           Testnet.Components.Query (EpochStateView, checkDRepState,
                    findLargestUtxoForPaymentKey, getCurrentEpochNo, getEpochStateView,
-                   getMinDRepDeposit)
+                   getMinDRepDeposit, watchEpochStateView)
 import           Testnet.Components.TestWatchdog
 import           Testnet.Defaults
 import qualified Testnet.Process.Cli as P
@@ -192,45 +190,23 @@ activityChangeProposalTest execConfig epochStateView configurationFile socketPat
   (EpochNo epochAfterProp) <- getCurrentEpochNo epochStateView
   H.note_ $ "Epoch after \"" <> prefix <> "\" prop: " <> show epochAfterProp
 
-  waitAndCheck epochAfterProp
+  watchEpochStateView epochStateView isSuccess minWait maxWait
 
   return thisProposal
 
   where
-    waitAndCheck :: (MonadTest m, MonadIO m)
-                 => Word64 -> m ()
-    waitAndCheck epochAfterProp = do
-      !eProposalResult
-        <- evalIO . runExceptT $ foldEpochState
-                                    (File configurationFile)
-                                    (File socketPath)
-                                    FullValidation
-                                    (EpochNo (epochAfterProp + maxWait))
-                                    ()
-                                    (\epochState _ _ -> filterEpochState (isSuccess epochAfterProp) epochState)
-      void $ evalEither eProposalResult
-
-    filterEpochState :: (EpochNo -> EpochInterval -> Bool) -> AnyNewEpochState -> StateT () IO LedgerStateCondition
-    filterEpochState f (AnyNewEpochState sbe newEpochState) =
-        caseShelleyToBabbageOrConwayEraOnwards
-          (const $ error "activityChangeProposalTest: Only conway era onwards supported")
-          (const $ do
-            let pParams = newEpochState ^. nesEpochStateL . epochStateGovStateL . curPParamsGovStateL . ppDRepActivityL
-                currEpoch = nesEL newEpochState
-            return (if f currEpoch pParams
-                    then ConditionMet
-                    else ConditionNotMet)
-          )
-          sbe
-
-    isSuccess :: Word64 -> EpochNo -> EpochInterval -> Bool
-    isSuccess epochAfterProp (EpochNo epochNo) (EpochInterval epochInterval) =
-      (epochAfterProp + minWait <= epochNo) &&
-      (case mExpected of
-        Nothing -> True
-        Just expected -> epochInterval == expected) &&
-      (epochNo <= epochAfterProp + maxWait)
-
+    isSuccess :: (HasCallStack, MonadTest m)
+              => AnyNewEpochState -> m (Maybe ())
+    isSuccess (AnyNewEpochState sbe newEpochState) =
+      caseShelleyToBabbageOrConwayEraOnwards
+        (const $ error "activityChangeProposalTest: Only conway era onwards supported")
+        (const $ do
+          let (EpochInterval epochInterval) = newEpochState ^. nesEpochStateL . epochStateGovStateL . curPParamsGovStateL . ppDRepActivityL
+          return (case mExpected of
+                    Nothing -> Just ()
+                    Just expected -> if epochInterval == expected then Just () else Nothing)
+        )
+        sbe
 
 makeActivityChangeProposal
   :: (HasCallStack, H.MonadAssertion m, MonadTest m, MonadCatch m, MonadIO m)

cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs

@@ -37,6 +37,7 @@ import           Test.Tasty (TestTree)
 import qualified Test.Tasty.Ingredients as T
 import qualified Test.Tasty.Options as T
 import qualified Test.Tasty.Runners as T
+import qualified Cardano.Testnet.Test.Gov.DRepActivity as Cardano.Testnet.Test.LedgerEvents.Gov.DRepActivity
 
 tests :: IO TestTree
 tests = do
@@ -48,8 +49,7 @@ tests = do
             -- TODO: Replace foldBlocks with checkLedgerStateCondition
             , T.testGroup "Governance"
                 [ H.ignoreOnMacAndWindows "ProposeAndRatifyNewConstitution" Cardano.Testnet.Test.Gov.ProposeNewConstitution.hprop_ledger_events_propose_new_constitution
-               -- TODO: "DRep Activity" is too flaky at the moment. Disabling until we can fix it.
-               -- , H.ignoreOnWindows "DRep Activity" Cardano.Testnet.Test.LedgerEvents.Gov.DRepActivity.hprop_check_drep_activity
+                , H.ignoreOnWindows "DRep Activity" Cardano.Testnet.Test.LedgerEvents.Gov.DRepActivity.hprop_check_drep_activity
                 , H.ignoreOnWindows "DRep Deposits" Cardano.Testnet.Test.Gov.DRepDeposits.hprop_ledger_events_drep_deposits
                   -- FIXME Those tests are flaky
                   -- , H.ignoreOnWindows "InfoAction" LedgerEvents.hprop_ledger_events_info_action