Skip to content

Commit 4b29bb6

Browse files
palasnfrisby
authored andcommitted
Merge pull request #5815 from IntersectMBO/automated-drep-scenario1
Automated drep (Scenario 1)
2 parents 6821a56 + 5b16cd1 commit 4b29bb6

File tree

17 files changed

+551
-212
lines changed

17 files changed

+551
-212
lines changed

cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1205,12 +1205,13 @@ instance ( tx ~ GenTx blk
12051205
, "current slot" .= toJSON (unSlotNo currentSlot)
12061206
, "tip" .= toJSON (unSlotNo tip)
12071207
]
1208-
forMachine dtal (TraceBlockContext currentSlot tipBlkNo tipPoint) =
1208+
forMachine dtal (TraceBlockContext currentSlot tipBlkNo tipPoint durNSec) =
12091209
mconcat
12101210
[ "kind" .= String "TraceBlockContext"
12111211
, "current slot" .= toJSON (unSlotNo currentSlot)
12121212
, "tip" .= renderPointForDetails dtal tipPoint
12131213
, "tipBlockNo" .= toJSON (unBlockNo tipBlkNo)
1214+
, "durNSec" .= toJSON durNSec
12141215
]
12151216
forMachine _dtal (TraceNoLedgerState slotNo _pt) =
12161217
mconcat
@@ -1333,11 +1334,12 @@ instance ( tx ~ GenTx blk
13331334
"Couldn't forge block because current tip is in the future: "
13341335
<> "current tip slot: " <> showT (unSlotNo tipSlot)
13351336
<> ", current slot: " <> showT (unSlotNo currentSlot)
1336-
forHuman (TraceBlockContext currentSlot tipBlockNo tipPoint) =
1337+
forHuman (TraceBlockContext currentSlot tipBlockNo tipPoint durNSec) =
13371338
"New block will fit onto: "
13381339
<> "tip: " <> renderPointAsPhrase tipPoint
13391340
<> ", tip block no: " <> showT (unBlockNo tipBlockNo)
13401341
<> ", current slot: " <> showT (unSlotNo currentSlot)
1342+
<> ", duration (nsec): " <> showT durNSec
13411343
forHuman (TraceNoLedgerState slotNo pt) =
13421344
"Could not obtain ledger state for point "
13431345
<> renderPointAsPhrase pt
@@ -1422,7 +1424,7 @@ instance ( tx ~ GenTx blk
14221424
[IntM "Forge.SlotIsImmutable" (fromIntegral $ unSlotNo slot)]
14231425
asMetrics (TraceBlockFromFuture slot _slotNo) =
14241426
[IntM "Forge.BlockFromFuture" (fromIntegral $ unSlotNo slot)]
1425-
asMetrics (TraceBlockContext slot _tipBlkNo _tipPoint) =
1427+
asMetrics (TraceBlockContext slot _tipBlkNo _tipPoint _durNSec) =
14261428
[IntM "Forge.BlockContext" (fromIntegral $ unSlotNo slot)]
14271429
asMetrics (TraceNoLedgerState slot _) =
14281430
[IntM "Forge.CouldNotForgeSlotLast" (fromIntegral $ unSlotNo slot)]

cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -386,11 +386,12 @@ instance ( tx ~ GenTx blk
386386
"Couldn't forge block because current tip is in the future: "
387387
<> "current tip slot: " <> showT (unSlotNo tipSlot)
388388
<> ", current slot: " <> showT (unSlotNo currentSlot)
389-
TraceBlockContext currentSlot tipBlockNo tipPoint -> const $
389+
TraceBlockContext currentSlot tipBlockNo tipPoint durNSec -> const $
390390
"New block will fit onto: "
391391
<> "tip: " <> renderPointAsPhrase tipPoint
392392
<> ", tip block no: " <> showT (unBlockNo tipBlockNo)
393393
<> ", current slot: " <> showT (unSlotNo currentSlot)
394+
<> ", duration (nsec): " <> showT durNSec
394395
TraceNoLedgerState slotNo pt -> const $
395396
"Could not obtain ledger state for point "
396397
<> renderPointAsPhrase pt
@@ -1454,12 +1455,13 @@ instance ( RunNode blk
14541455
, "current slot" .= toJSON (unSlotNo currentSlot)
14551456
, "tip" .= toJSON (unSlotNo tip)
14561457
]
1457-
toObject verb (TraceBlockContext currentSlot tipBlkNo tipPoint) =
1458+
toObject verb (TraceBlockContext currentSlot tipBlkNo tipPoint durNSec) =
14581459
mconcat
14591460
[ "kind" .= String "TraceBlockContext"
14601461
, "current slot" .= toJSON (unSlotNo currentSlot)
14611462
, "tip" .= renderPointForVerbosity verb tipPoint
14621463
, "tipBlockNo" .= toJSON (unBlockNo tipBlkNo)
1464+
, "durNSec" .= toJSON durNSec
14631465
]
14641466
toObject _verb (TraceNoLedgerState slotNo _pt) =
14651467
mconcat

cardano-node/src/Cardano/Tracing/Tracers.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1077,7 +1077,7 @@ teeForge' tr =
10771077
LogValue "slotIsImmutable" $ PureI $ fromIntegral $ unSlotNo slot
10781078
Consensus.TraceBlockFromFuture slot _slotNo ->
10791079
LogValue "blockFromFuture" $ PureI $ fromIntegral $ unSlotNo slot
1080-
Consensus.TraceBlockContext slot _tipBlkNo _tipPoint ->
1080+
Consensus.TraceBlockContext slot _tipBlkNo _tipPoint _durNSec ->
10811081
LogValue "blockContext" $ PureI $ fromIntegral $ unSlotNo slot
10821082
Consensus.TraceNoLedgerState slot _ ->
10831083
LogValue "couldNotForgeSlotLast" $ PureI $ fromIntegral $ unSlotNo slot

cardano-testnet/cardano-testnet.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -198,6 +198,8 @@ test-suite cardano-testnet-test
198198
Cardano.Testnet.Test.Gov.TreasuryGrowth
199199
Cardano.Testnet.Test.Gov.TreasuryWithdrawal
200200
Cardano.Testnet.Test.Misc
201+
Cardano.Testnet.Test.Gov.DRepActivity
202+
Cardano.Testnet.Test.Gov.PredefinedAbstainDRep
201203
Cardano.Testnet.Test.Node.Shutdown
202204
Cardano.Testnet.Test.SanityCheck
203205
Cardano.Testnet.Test.SubmitApi.Babbage.Transaction

cardano-testnet/src/Cardano/Testnet.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,6 @@ module Cardano.Testnet (
2727

2828
-- * EpochState processsing helper functions
2929
maybeExtractGovernanceActionIndex,
30-
findCondition,
3130

3231
-- * Processes
3332
procChairman,

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

Lines changed: 79 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,10 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE NumericUnderscores #-}
46
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE RankNTypes #-}
58
{-# LANGUAGE ScopedTypeVariables #-}
69

710
module Testnet.Components.Query
@@ -20,21 +23,24 @@ module Testnet.Components.Query
2023
, findUtxosWithAddress
2124
, findLargestUtxoWithAddress
2225
, findLargestUtxoForPaymentKey
26+
, assertNewEpochState
27+
, watchEpochStateView
2328
) where
2429

2530
import Cardano.Api as Api
26-
import Cardano.Api.Ledger (Credential, DRepState, KeyRole (DRepRole), StandardCrypto)
31+
import Cardano.Api.Ledger (Credential, DRepState, EpochInterval (..), KeyRole (DRepRole),
32+
StandardCrypto)
2733
import Cardano.Api.Shelley (ShelleyLedgerEra, fromShelleyTxIn, fromShelleyTxOut)
2834

2935
import qualified Cardano.Ledger.Api as L
30-
import Cardano.Ledger.BaseTypes (EpochInterval, addEpochInterval)
3136
import qualified Cardano.Ledger.Coin as L
3237
import qualified Cardano.Ledger.Conway.Governance as L
3338
import qualified Cardano.Ledger.Conway.PParams as L
3439
import qualified Cardano.Ledger.Shelley.LedgerState as L
3540
import qualified Cardano.Ledger.UTxO as L
3641

3742
import Control.Exception.Safe (MonadCatch)
43+
import Control.Monad (void)
3844
import Control.Monad.Trans.Resource
3945
import Control.Monad.Trans.State.Strict (put)
4046
import Data.Bifunctor (bimap)
@@ -50,7 +56,7 @@ import qualified Data.Text as T
5056
import Data.Type.Equality
5157
import GHC.Exts (IsList (..))
5258
import GHC.Stack
53-
import Lens.Micro (to, (^.))
59+
import Lens.Micro (Lens', to, (^.))
5460

5561
import Testnet.Property.Assert
5662
import Testnet.Property.Util (runInBackground)
@@ -94,9 +100,9 @@ waitForEpochs
94100
=> EpochStateView
95101
-> EpochInterval -- ^ Number of epochs to wait
96102
-> m EpochNo -- ^ The epoch number reached
97-
waitForEpochs epochStateView@EpochStateView{nodeConfigPath, socketPath} interval = withFrozenCallStack $ do
98-
currentEpoch <- getCurrentEpochNo epochStateView
99-
waitUntilEpoch nodeConfigPath socketPath $ addEpochInterval currentEpoch interval
103+
waitForEpochs epochStateView interval = withFrozenCallStack $ do
104+
void $ watchEpochStateView epochStateView (const $ pure Nothing) interval
105+
getCurrentEpochNo epochStateView
100106

101107
-- | A read-only mutable pointer to an epoch state, updated automatically
102108
data EpochStateView = EpochStateView
@@ -353,3 +359,70 @@ getCurrentEpochNo
353359
getCurrentEpochNo epochStateView = withFrozenCallStack $ do
354360
AnyNewEpochState _ newEpochState <- getEpochState epochStateView
355361
pure $ newEpochState ^. L.nesELL
362+
363+
-- | Assert that the value pointed by the @lens@ in the epoch state is the same as the @expected@ value
364+
-- or it becomes the same within the @maxWait@ epochs. If the value is not reached within the time frame,
365+
-- the test fails.
366+
assertNewEpochState
367+
:: forall m era value.
368+
(Show value, MonadAssertion m, MonadTest m, MonadIO m, Eq value, HasCallStack)
369+
=> EpochStateView -- ^ Current epoch state view. It can be obtained using the 'getEpochStateView' function.
370+
-> ConwayEraOnwards era -- ^ The ConwayEraOnwards witness for current era.
371+
-> value -- ^ The expected value to check in the epoch state.
372+
-> EpochInterval -- ^ The maximum wait time in epochs.
373+
-> Lens' (L.NewEpochState (ShelleyLedgerEra era)) value -- ^ The lens to access the specific value in the epoch state.
374+
-> m ()
375+
assertNewEpochState epochStateView ceo expected maxWait lens = withFrozenCallStack $ do
376+
let sbe = conwayEraOnwardsToShelleyBasedEra ceo
377+
mStateView <- watchEpochStateView epochStateView (checkEpochState sbe) maxWait
378+
case mStateView of
379+
Just () -> pure ()
380+
Nothing -> do epochState <- getEpochState epochStateView
381+
val <- getFromEpochState sbe epochState
382+
if val == expected
383+
then pure ()
384+
else H.failMessage callStack $ unlines
385+
[ "assertNewEpochState: expected value not reached within the time frame."
386+
, "Expected value: " <> show expected
387+
, "Actual value: " <> show val
388+
]
389+
where
390+
checkEpochState :: HasCallStack
391+
=> ShelleyBasedEra era -> AnyNewEpochState -> m (Maybe ())
392+
checkEpochState sbe newEpochState = do
393+
val <- getFromEpochState sbe newEpochState
394+
return $ if val == expected then Just () else Nothing
395+
396+
getFromEpochState :: HasCallStack
397+
=> ShelleyBasedEra era -> AnyNewEpochState -> m value
398+
getFromEpochState sbe (AnyNewEpochState actualEra newEpochState) = do
399+
Refl <- either error pure $ assertErasEqual sbe actualEra
400+
return $ newEpochState ^. lens
401+
402+
-- | Watch the epoch state view until the guard function returns 'Just' or the timeout epoch is reached.
403+
-- Wait for at most @maxWait@ epochs.
404+
-- The function will return the result of the guard function if it is met, otherwise it will return @Nothing@.
405+
watchEpochStateView
406+
:: forall m a. (HasCallStack, MonadIO m, MonadTest m, MonadAssertion m)
407+
=> EpochStateView -- ^ The info to access the epoch state
408+
-> (AnyNewEpochState -> m (Maybe a)) -- ^ The guard function (@Just@ if the condition is met, @Nothing@ otherwise)
409+
-> EpochInterval -- ^ The maximum number of epochs to wait
410+
-> m (Maybe a)
411+
watchEpochStateView epochStateView f (EpochInterval maxWait) = withFrozenCallStack $ do
412+
AnyNewEpochState _ newEpochState <- getEpochState epochStateView
413+
let EpochNo currentEpoch = L.nesEL newEpochState
414+
go (EpochNo $ currentEpoch + fromIntegral maxWait)
415+
where
416+
go :: EpochNo -> m (Maybe a)
417+
go (EpochNo timeout) = do
418+
epochState@(AnyNewEpochState _ newEpochState') <- getEpochState epochStateView
419+
let EpochNo currentEpoch = L.nesEL newEpochState'
420+
condition <- f epochState
421+
case condition of
422+
Just result -> pure (Just result)
423+
Nothing -> do
424+
if currentEpoch > timeout
425+
then pure Nothing
426+
else do
427+
H.threadDelay 10_000
428+
go (EpochNo timeout)
Lines changed: 42 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -1,65 +1,40 @@
11
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE NumericUnderscores #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE RankNTypes #-}
34
{-# LANGUAGE ScopedTypeVariables #-}
45
{-# LANGUAGE TypeFamilies #-}
56

67
module Testnet.EpochStateProcessing
78
( maybeExtractGovernanceActionIndex
8-
, findCondition
9-
, watchEpochStateView
9+
, waitForGovActionVotes
1010
) where
1111

1212
import Cardano.Api
13-
import Cardano.Api.Ledger (EpochInterval (..), GovActionId (..))
13+
import Cardano.Api.Ledger (EpochInterval, GovActionId (..))
1414
import qualified Cardano.Api.Ledger as L
15+
import Cardano.Api.Shelley (ShelleyLedgerEra)
1516

1617
import qualified Cardano.Ledger.Conway.Governance as L
1718
import qualified Cardano.Ledger.Shelley.API as L
19+
import Cardano.Ledger.Shelley.LedgerState (newEpochStateGovStateL)
1820
import qualified Cardano.Ledger.Shelley.LedgerState as L
1921

2022
import Prelude
2123

22-
import Control.Monad.State.Strict (MonadState (put), StateT)
24+
import Data.Data ((:~:) (..))
2325
import qualified Data.Map as Map
2426
import Data.Word (Word32)
27+
import GHC.Exts (IsList (toList), toList)
2528
import GHC.Stack
26-
import Lens.Micro ((^.))
29+
import Lens.Micro (to, (^.))
2730

28-
import Testnet.Components.Query (EpochStateView, getEpochState)
31+
import Testnet.Components.Query (EpochStateView, watchEpochStateView)
32+
import Testnet.Property.Assert (assertErasEqual)
2933

30-
import Hedgehog
34+
import Hedgehog (MonadTest)
3135
import Hedgehog.Extras (MonadAssertion)
3236
import qualified Hedgehog.Extras as H
3337

34-
findCondition
35-
:: HasCallStack
36-
=> MonadTest m
37-
=> MonadIO m
38-
=> (AnyNewEpochState -> Maybe a)
39-
-> NodeConfigFile In
40-
-> SocketPath
41-
-> EpochNo -- ^ The termination epoch: the condition must be found *before* this epoch
42-
-> m (Either FoldBlocksError (Maybe a))
43-
findCondition epochStateFoldFunc configurationFile socketPath maxEpochNo = withFrozenCallStack $ evalIO . runExceptT $ do
44-
result <-
45-
foldEpochState
46-
configurationFile
47-
socketPath
48-
FullValidation
49-
maxEpochNo
50-
Nothing
51-
(\epochState _ _ -> go epochStateFoldFunc epochState)
52-
pure $ case result of
53-
(ConditionMet, Just x) -> Just x
54-
_ -> Nothing
55-
56-
where
57-
go :: (AnyNewEpochState -> Maybe a) -> AnyNewEpochState -> StateT (Maybe a) IO LedgerStateCondition
58-
go f epochState = do
59-
case f epochState of
60-
Just x -> put (Just x) >> pure ConditionMet
61-
Nothing -> pure ConditionNotMet
62-
6338
maybeExtractGovernanceActionIndex
6439
:: HasCallStack
6540
=> TxId -- ^ transaction id searched for
@@ -78,31 +53,33 @@ maybeExtractGovernanceActionIndex txid (AnyNewEpochState sbe newEpochState) =
7853
| ti1 == L.extractHash ti2 = Just gai
7954
compareWithTxId _ x _ _ = x
8055

81-
-- | Watch the epoch state view until the guard function returns 'Just' or the timeout epoch is reached.
82-
-- Wait for at most @maxWait@ epochs.
83-
-- The function will return the result of the guard function if it is met, otherwise it will return @Nothing@.
84-
watchEpochStateView
85-
:: forall m a. (HasCallStack, MonadIO m, MonadTest m, MonadAssertion m)
86-
=> EpochStateView -- ^ The info to access the epoch state
87-
-> (AnyNewEpochState -> m (Maybe a)) -- ^ The guard function (@Just@ if the condition is met, @Nothing@ otherwise)
88-
-> EpochInterval -- ^ The maximum number of epochs to wait
89-
-> m (Maybe a)
90-
watchEpochStateView epochStateView f (EpochInterval maxWait) = withFrozenCallStack $ do
91-
AnyNewEpochState _ newEpochState <- getEpochState epochStateView
92-
let EpochNo currentEpoch = L.nesEL newEpochState
93-
go (EpochNo $ currentEpoch + fromIntegral maxWait)
94-
where
95-
go :: EpochNo -> m (Maybe a)
96-
go (EpochNo timeout) = do
97-
epochState@(AnyNewEpochState _ newEpochState') <- getEpochState epochStateView
98-
let EpochNo currentEpoch = L.nesEL newEpochState'
99-
condition <- f epochState
100-
case condition of
101-
Just result -> pure (Just result)
102-
Nothing -> do
103-
if currentEpoch > timeout
104-
then pure Nothing
105-
else do
106-
H.threadDelay 100_000
107-
go (EpochNo timeout)
108-
56+
-- | Wait for the last gov action proposal in the list to have DRep or SPO votes.
57+
waitForGovActionVotes
58+
:: forall m era.
59+
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack)
60+
=> EpochStateView -- ^ Current epoch state view. It can be obtained using the 'getEpochStateView' function.
61+
-> ConwayEraOnwards era -- ^ The ConwayEraOnwards witness for current era.
62+
-> EpochInterval -- ^ The maximum wait time in epochs.
63+
-> m ()
64+
waitForGovActionVotes epochStateView ceo maxWait = withFrozenCallStack $ do
65+
mResult <- watchEpochStateView epochStateView getFromEpochState maxWait
66+
case mResult of
67+
Just () -> pure ()
68+
Nothing -> H.failMessage callStack "waitForGovActionVotes: No votes appeared before timeout."
69+
where
70+
getFromEpochState :: HasCallStack
71+
=> AnyNewEpochState -> m (Maybe ())
72+
getFromEpochState (AnyNewEpochState actualEra newEpochState) = do
73+
let sbe = conwayEraOnwardsToShelleyBasedEra ceo
74+
Refl <- H.leftFail $ assertErasEqual sbe actualEra
75+
let govState :: L.ConwayGovState (ShelleyLedgerEra era) = conwayEraOnwardsConstraints ceo $ newEpochState ^. newEpochStateGovStateL
76+
proposals = govState ^. L.cgsProposalsL . L.pPropsL . to toList
77+
if null proposals
78+
then pure Nothing
79+
else do
80+
let lastProposal = last proposals
81+
gaDRepVotes = lastProposal ^. L.gasDRepVotesL . to toList
82+
gaSpoVotes = lastProposal ^. L.gasStakePoolVotesL . to toList
83+
if null gaDRepVotes && null gaSpoVotes
84+
then pure Nothing
85+
else pure $ Just ()

0 commit comments

Comments
 (0)