diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 4abf69dc47..67f01026b3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1518,6 +1518,16 @@ class (BlockStateQuery m) => BlockStateOperations m where -- round did timeout. bsoUpdateMissedRounds :: (PVSupportsDelegation (MPV m), PVSupportsValidatorSuspension (MPV m)) => UpdatableBlockState m -> Map.Map BakerId Word64 -> m (UpdatableBlockState m) + -- | Mark given validators for possible suspension at the next snapshot epoch. + bsoPrimeForSuspension :: (PVSupportsDelegation (MPV m), PVSupportsValidatorSuspension (MPV m)) => UpdatableBlockState m -> Word64 -> [BakerId] -> m ([BakerId], UpdatableBlockState m) + + -- \| Suspend validators with the given account indices, if + -- 1) the account index points to an existing account + -- 2) the account belongs to a validator + -- 3) the account was not already suspended + -- Returns the subset of account indices that were suspended. + bsoSuspendValidators :: (PVSupportsValidatorSuspension (MPV m)) => UpdatableBlockState m -> [AccountIndex] -> m ([AccountIndex], UpdatableBlockState m) + -- | A snapshot of the block state that can be used to roll back to a previous state. type StateSnapshot m @@ -1830,6 +1840,8 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat bsoSetRewardAccounts s = lift . bsoSetRewardAccounts s bsoIsProtocolUpdateEffective = lift . bsoIsProtocolUpdateEffective bsoUpdateMissedRounds s = lift . bsoUpdateMissedRounds s + bsoPrimeForSuspension s t = lift . bsoPrimeForSuspension s t + bsoSuspendValidators s = lift . bsoSuspendValidators s type StateSnapshot (MGSTrans t m) = StateSnapshot m bsoSnapshotState = lift . bsoSnapshotState bsoRollback s = lift . bsoRollback s @@ -1887,6 +1899,8 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat {-# INLINE bsoGetCurrentEpochBakers #-} {-# INLINE bsoIsProtocolUpdateEffective #-} {-# INLINE bsoUpdateMissedRounds #-} + {-# INLINE bsoPrimeForSuspension #-} + {-# INLINE bsoSuspendValidators #-} {-# INLINE bsoSnapshotState #-} {-# INLINE bsoRollback #-} diff --git a/concordium-consensus/src/Concordium/GlobalState/DummyData.hs b/concordium-consensus/src/Concordium/GlobalState/DummyData.hs index 749630516c..311bc664d5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/DummyData.hs +++ b/concordium-consensus/src/Concordium/GlobalState/DummyData.hs @@ -364,6 +364,14 @@ dummyFinalizationCommitteeParameters = _fcpFinalizerRelativeStakeThreshold = PartsPerHundredThousands 10000 } +-- | Validator score parameters for the second consensus protocol. +dummyValidatorScoreParameters :: ValidatorScoreParameters +dummyValidatorScoreParameters = + ValidatorScoreParameters + { -- Maximal number of missed rounds before a validator gets suspended. + _vspMaxMissedRounds = 1 + } + dummyChainParameters :: forall cpv. (IsChainParametersVersion cpv) => ChainParameters' cpv dummyChainParameters = case chainParametersVersion @cpv of SChainParametersV0 -> @@ -382,7 +390,8 @@ dummyChainParameters = case chainParametersVersion @cpv of PoolParametersV0 { _ppBakerStakeThreshold = 300000000000 }, - _cpFinalizationCommitteeParameters = NoParam + _cpFinalizationCommitteeParameters = NoParam, + _cpValidatorScoreParameters = NoParam } SChainParametersV1 -> ChainParameters @@ -420,7 +429,8 @@ dummyChainParameters = case chainParametersVersion @cpv of _transactionCommissionRange = fullRange } }, - _cpFinalizationCommitteeParameters = NoParam + _cpFinalizationCommitteeParameters = NoParam, + _cpValidatorScoreParameters = NoParam } SChainParametersV2 -> ChainParameters @@ -458,7 +468,8 @@ dummyChainParameters = case chainParametersVersion @cpv of _transactionCommissionRange = fullRange } }, - _cpFinalizationCommitteeParameters = SomeParam dummyFinalizationCommitteeParameters + _cpFinalizationCommitteeParameters = SomeParam dummyFinalizationCommitteeParameters, + _cpValidatorScoreParameters = NoParam } SChainParametersV3 -> ChainParameters @@ -496,7 +507,8 @@ dummyChainParameters = case chainParametersVersion @cpv of _transactionCommissionRange = fullRange } }, - _cpFinalizationCommitteeParameters = SomeParam dummyFinalizationCommitteeParameters + _cpFinalizationCommitteeParameters = SomeParam dummyFinalizationCommitteeParameters, + _cpValidatorScoreParameters = SomeParam dummyValidatorScoreParameters } where fullRange = InclusiveRange (makeAmountFraction 0) (makeAmountFraction 100000) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 7850fd6461..138f320a06 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -1563,6 +1563,7 @@ instance (MonadBlobStore m, IsCooldownParametersVersion cpv) => BlobStorable m ( instance (MonadBlobStore m) => BlobStorable m Parameters.TimeParameters instance (MonadBlobStore m) => BlobStorable m Parameters.TimeoutParameters instance (MonadBlobStore m) => BlobStorable m Parameters.FinalizationCommitteeParameters +instance (MonadBlobStore m) => BlobStorable m Parameters.ValidatorScoreParameters instance (MonadBlobStore m) => BlobStorable m Duration instance (MonadBlobStore m) => BlobStorable m Energy instance (MonadBlobStore m) => BlobStorable m (Map AccountAddress Timestamp) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index ef5b872b8c..68865b0b2b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -71,6 +71,7 @@ import qualified Concordium.GlobalState.Persistent.LFMBTree as LFMBT import Concordium.GlobalState.Persistent.PoolRewards import Concordium.GlobalState.Persistent.ReleaseSchedule import qualified Concordium.GlobalState.Persistent.Trie as Trie +import Concordium.GlobalState.PoolRewards import qualified Concordium.GlobalState.Rewards as Rewards import qualified Concordium.GlobalState.TransactionTable as TransactionTable import Concordium.GlobalState.Types @@ -1867,7 +1868,11 @@ newUpdateValidator pbs curTimestamp ai vu@ValidatorUpdate{..} = do case sSupportsValidatorSuspension (accountVersion @(AccountVersionFor pv)) of STrue -> do acc1 <- setAccountValidatorSuspended suspend acc - MTL.tell [if suspend then BakerConfigureSuspended else BakerConfigureResumed] + MTL.tell + [ if suspend + then BakerConfigureSuspended + else BakerConfigureResumed + ] return (bsp, acc1) SFalse -> return (bsp, acc) updateKeys oldBaker = ifPresent vuKeys $ \keys (bsp, acc) -> do @@ -3492,12 +3497,94 @@ doUpdateMissedRounds pbs rds = do modifyBakerPoolRewardDetailsInPoolRewards bsp0 bId - (\bprd -> bprd{missedRounds = (+ newMissedRounds) <$> missedRounds bprd}) + ( \bprd -> + bprd + { suspensionInfo = + (\SuspensionInfo{..} -> SuspensionInfo{missedRounds = missedRounds + newMissedRounds, ..}) + <$> suspensionInfo bprd + } + ) ) bsp (Map.toList rds) storePBS pbs bsp' +doPrimeForSuspension :: + ( PVSupportsDelegation pv, + SupportsPersistentState pv m + ) => + PersistentBlockState pv -> + Word64 -> + [BakerId] -> + m ([BakerId], PersistentBlockState pv) +doPrimeForSuspension pbs threshold bids = do + bprds <- doGetBakerPoolRewardDetails pbs + bsp0 <- loadPBS pbs + (bidsUpd, bsp') <- do + foldM + ( \res@(acc, bsp) bId -> do + let mBprd = Map.lookup bId bprds + case mBprd of + Just bprd + | CTrue SuspensionInfo{..} <- suspensionInfo bprd, + missedRounds > threshold -> do + bsp' <- + modifyBakerPoolRewardDetailsInPoolRewards + bsp + bId + (\bpr -> bpr{suspensionInfo = (\suspInfo -> suspInfo{primedForSuspension = True}) <$> suspensionInfo bpr}) + return (bId : acc, bsp') + _otherwise -> return res + ) + ([], bsp0) + bids + pbs' <- storePBS pbs bsp' + return (bidsUpd, pbs') + +-- | Suspend validators with the given account indices, if +-- 1) the account index points to an existing account +-- 2) the account belongs to a validator +-- 3) the account was not already suspended +-- Returns the subset of account indeces that were suspended. +doSuspendValidators :: + forall pv m. + ( SupportsPersistentState pv m + ) => + PersistentBlockState pv -> + [AccountIndex] -> + m ([AccountIndex], PersistentBlockState pv) +doSuspendValidators pbs ais = + case hasValidatorSuspension of + STrue -> do + bsp0 <- loadPBS pbs + (aisSusp, bspUpd) <- + foldM + ( \res@(aisSusp, bsp) ai -> do + mAcc <- Accounts.indexedAccount ai (bspAccounts bsp) + case mAcc of + Nothing -> return res + Just acc -> do + mValidatorExists <- accountBaker acc + case mValidatorExists of + Nothing -> return res + Just ba + -- The validator is not yet suspended + | False <- + uncond $ BaseAccounts._bieAccountIsSuspended $ _accountBakerInfo ba -> do + newAcc <- setAccountValidatorSuspended True acc + newAccounts <- Accounts.setAccountAtIndex ai newAcc (bspAccounts bsp) + return (ai : aisSusp, bsp{bspAccounts = newAccounts}) + -- The validator is already suspended, nothing to do + | otherwise -> return res + ) + ([], bsp0) + ais + pbsUpd <- storePBS pbs bspUpd + return (aisSusp, pbsUpd) + SFalse -> return ([], pbs) + where + hasValidatorSuspension = sSupportsValidatorSuspension (accountVersion @(AccountVersionFor pv)) + doProcessUpdateQueues :: forall pv m. (SupportsPersistentState pv m) => @@ -3694,7 +3781,7 @@ doNotifyBlockBaked pbs bid = do let incBPR bpr = bpr { blockCount = blockCount bpr + 1, - missedRounds = 0 <$ missedRounds bpr + suspensionInfo = emptySuspensionInfo <$ suspensionInfo bpr } in storePBS pbs =<< modifyBakerPoolRewardDetailsInPoolRewards bsp bid incBPR @@ -3735,7 +3822,7 @@ doMarkFinalizationAwakeBakers pbs bids = do ( (), bpr { finalizationAwake = True, - missedRounds = 0 <$ missedRounds bpr + suspensionInfo = emptySuspensionInfo <$ suspensionInfo bpr } ) @@ -4387,6 +4474,8 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoSetRewardAccounts = doSetRewardAccounts bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective bsoUpdateMissedRounds = doUpdateMissedRounds + bsoPrimeForSuspension = doPrimeForSuspension + bsoSuspendValidators = doSuspendValidators type StateSnapshot (PersistentBlockStateMonad pv r m) = BlockStatePointers pv bsoSnapshotState = loadPBS bsoRollback = storePBS diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs index e824aeb0f7..8bc37c92ca 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs @@ -242,7 +242,9 @@ data PendingUpdates (cpv :: ChainParametersVersion) = PendingUpdates -- | Block energy limit (CPV2 onwards). pBlockEnergyLimitQueue :: !(HashedBufferedRefO 'PTBlockEnergyLimit cpv (UpdateQueue Energy)), -- | Finalization committee parameters (CPV2 onwards). - pFinalizationCommitteeParametersQueue :: !(HashedBufferedRefO 'PTFinalizationCommitteeParameters cpv (UpdateQueue FinalizationCommitteeParameters)) + pFinalizationCommitteeParametersQueue :: !(HashedBufferedRefO 'PTFinalizationCommitteeParameters cpv (UpdateQueue FinalizationCommitteeParameters)), + -- | Validators score parameters (CPV3 onwards). + pValidatorScoreParametersQueue :: !(HashedBufferedRefO 'PTValidatorScoreParameters cpv (UpdateQueue ValidatorScoreParameters)) } -- | See documentation of @migratePersistentBlockState@. @@ -422,6 +424,25 @@ migratePendingUpdates migration PendingUpdates{..} = withCPVConstraints (chainPa SomeParam hbr -> SomeParam <$> migrateHashedBufferedRef (migrateUpdateQueue id) hbr StateMigrationParametersP7ToP8{} -> case pFinalizationCommitteeParametersQueue of SomeParam hbr -> SomeParam <$> migrateHashedBufferedRef (migrateUpdateQueue id) hbr + newValidatorScoreParametersQueue <- case migration of + StateMigrationParametersTrivial -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + SomeParam hbr -> SomeParam <$> migrateHashedBufferedRef (migrateUpdateQueue id) hbr + StateMigrationParametersP1P2 -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP2P3 -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP3ToP4{} -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP4ToP5{} -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP5ToP6{} -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP6ToP7{} -> case pValidatorScoreParametersQueue of + NoParam -> return NoParam + StateMigrationParametersP7ToP8{} -> do + (!hbr, _) <- refFlush =<< refMake emptyUpdateQueue + return (SomeParam hbr) return $! PendingUpdates { pRootKeysUpdateQueue = newRootKeys, @@ -443,7 +464,8 @@ migratePendingUpdates migration PendingUpdates{..} = withCPVConstraints (chainPa pTimeoutParametersQueue = newTimeoutParameters, pMinBlockTimeQueue = newMinBlockTimeQueue, pBlockEnergyLimitQueue = newBlockEnergyLimitQueue, - pFinalizationCommitteeParametersQueue = newFinalizationCommitteeParametersQueue + pFinalizationCommitteeParametersQueue = newFinalizationCommitteeParametersQueue, + pValidatorScoreParametersQueue = newValidatorScoreParametersQueue } instance @@ -522,6 +544,7 @@ instance (putMinBlockTimeQueue, newMinBlockTimeQueue) <- storeUpdate pMinBlockTimeQueue (putBlockEnergyLimitQueue, newBlockEnergyLimitQueue) <- storeUpdate pBlockEnergyLimitQueue (putFinalizationCommitteeParametersQueue, newFinalizationCommitteeParametersQueue) <- storeUpdate pFinalizationCommitteeParametersQueue + (putValidatorScoreParametersQueue, newValidatorScoreParametersQueue) <- storeUpdate pValidatorScoreParametersQueue let newPU = PendingUpdates { pRootKeysUpdateQueue = rkQ, @@ -543,7 +566,8 @@ instance pTimeoutParametersQueue = newTimeoutParametersQueue, pMinBlockTimeQueue = newMinBlockTimeQueue, pBlockEnergyLimitQueue = newBlockEnergyLimitQueue, - pFinalizationCommitteeParametersQueue = newFinalizationCommitteeParametersQueue + pFinalizationCommitteeParametersQueue = newFinalizationCommitteeParametersQueue, + pValidatorScoreParametersQueue = newValidatorScoreParametersQueue } let putPU = pRKQ @@ -566,6 +590,7 @@ instance >> putMinBlockTimeQueue >> putBlockEnergyLimitQueue >> putFinalizationCommitteeParametersQueue + >> putValidatorScoreParametersQueue return (putPU, newPU) load = withCPVConstraints (chainParametersVersion @cpv) $ do mRKQ <- label "Root keys update queue" load @@ -588,6 +613,7 @@ instance mMinBlockTimeQueue <- label "Minimum block time update queue" load mBlockEnergyLimitQueue <- label "Block energy limit update queue" load mFinalizationCommitteeParametersQueue <- label "Finalization committee parameters update queue" load + mValidatorScoreParametersQueue <- label "Validator score parameters update queue" load return $! do pRootKeysUpdateQueue <- mRKQ pLevel1KeysUpdateQueue <- mL1KQ @@ -609,6 +635,7 @@ instance pMinBlockTimeQueue <- mMinBlockTimeQueue pBlockEnergyLimitQueue <- mBlockEnergyLimitQueue pFinalizationCommitteeParametersQueue <- mFinalizationCommitteeParametersQueue + pValidatorScoreParametersQueue <- mValidatorScoreParametersQueue return PendingUpdates{..} instance @@ -638,6 +665,7 @@ instance <*> cache pMinBlockTimeQueue <*> cache pBlockEnergyLimitQueue <*> cache pFinalizationCommitteeParametersQueue + <*> cache pValidatorScoreParametersQueue where cpv = chainParametersVersion @cpv @@ -646,7 +674,7 @@ emptyPendingUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => m (PendingUpdates cpv) -emptyPendingUpdates = PendingUpdates <$> e <*> e <*> e <*> e <*> whenSupportedA e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e +emptyPendingUpdates = PendingUpdates <$> e <*> e <*> e <*> e <*> whenSupportedA e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e where e :: m (HashedBufferedRef (UpdateQueue a)) e = makeHashedBufferedRef emptyUpdateQueue @@ -678,6 +706,7 @@ makePersistentPendingUpdates UQ.PendingUpdates{..} = withCPVConstraints (chainPa pMinBlockTimeQueue <- mapM (refMake <=< makePersistentUpdateQueue) _pMinBlockTimeQueue pBlockEnergyLimitQueue <- mapM (refMake <=< makePersistentUpdateQueue) _pBlockEnergyLimitQueue pFinalizationCommitteeParametersQueue <- mapM (refMake <=< makePersistentUpdateQueue) _pFinalizationCommitteeParametersQueue + pValidatorScoreParametersQueue <- mapM (refMake <=< makePersistentUpdateQueue) _pValidatorScoreParametersQueue return PendingUpdates{..} -- | Convert a persistent 'PendingUpdates' to an in-memory 'UQ.PendingUpdates'. @@ -707,6 +736,7 @@ makeBasicPendingUpdates PendingUpdates{..} = withCPVConstraints (chainParameters _pMinBlockTimeQueue <- mapM (makeBasicUpdateQueue <=< refLoad) pMinBlockTimeQueue _pBlockEnergyLimitQueue <- mapM (makeBasicUpdateQueue <=< refLoad) pBlockEnergyLimitQueue _pFinalizationCommitteeParametersQueue <- mapM (makeBasicUpdateQueue <=< refLoad) pFinalizationCommitteeParametersQueue + _pValidatorScoreParametersQueue <- mapM (makeBasicUpdateQueue <=< refLoad) pValidatorScoreParametersQueue return UQ.PendingUpdates{..} -- | Current state of updatable parameters and update queues. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs index add62a8cf0..a7c774e8ee 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs @@ -147,7 +147,7 @@ migratePoolRewardsP1 curBakers nextBakers blockCounts npEpoch npMintRate = do { blockCount = Map.findWithDefault 0 bid blockCounts, transactionFeesAccrued = 0, finalizationAwake = False, - missedRounds = conditionally hasValidatorSuspension 0 + suspensionInfo = conditionally hasValidatorSuspension emptySuspensionInfo } (!newRef, _) <- refFlush =<< refMake bprd return newRef @@ -295,7 +295,7 @@ rotateCapitalDistribution oldPoolRewards = do buildRewardDetails (newId : newIds) (oldId : oldIds) (r : rs) = case compare newId oldId of LT -> emptyBakerPoolRewardDetails : buildRewardDetails newIds (oldId : oldIds) (r : rs) EQ -> - (emptyBakerPoolRewardDetails @av){missedRounds = missedRounds r} + (emptyBakerPoolRewardDetails @av){suspensionInfo = suspensionInfo r} : buildRewardDetails newIds oldIds rs GT -> buildRewardDetails (newId : newIds) oldIds rs buildRewardDetails _ _ _ = diff --git a/concordium-consensus/src/Concordium/GlobalState/PoolRewards.hs b/concordium-consensus/src/Concordium/GlobalState/PoolRewards.hs index e15d058fd0..f4db278c8b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/PoolRewards.hs +++ b/concordium-consensus/src/Concordium/GlobalState/PoolRewards.hs @@ -15,6 +15,28 @@ import Concordium.Types.Conditionally import Concordium.Types.HashableTo import Concordium.Utils.Serialization +-- | Information needed to determine whether to suspend a validator. +data SuspensionInfo = SuspensionInfo + { -- | The number of missed rounds since the validator most recently + -- became a (non-suspended) member of the validator committee. + missedRounds :: !Word64, + -- | Flag indicating that the validator should be suspended at the coming + -- snapshot epoch, because its missed rounds have crossed the threshold + -- given in the chain parameters in the previous reward period. + primedForSuspension :: !Bool + } + deriving (Eq, Show) + +emptySuspensionInfo :: SuspensionInfo +emptySuspensionInfo = SuspensionInfo{missedRounds = 0, primedForSuspension = False} + +instance Serialize SuspensionInfo where + put SuspensionInfo{..} = do + putWord64be missedRounds + putBool primedForSuspension + get = + SuspensionInfo <$> get <*> getBool + -- | 'BakerPoolRewardDetails' tracks the rewards that have been earned by a baker pool in the current -- reward period. These are used to pay out the rewards at the payday. data BakerPoolRewardDetails (av :: AccountVersion) = BakerPoolRewardDetails @@ -24,8 +46,8 @@ data BakerPoolRewardDetails (av :: AccountVersion) = BakerPoolRewardDetails transactionFeesAccrued :: !Amount, -- | Whether the pool contributed to a finalization proof in the reward period finalizationAwake :: !Bool, - -- | The number of missed rounds in the reward period - missedRounds :: !(Conditionally (SupportsValidatorSuspension av) Word64) + -- | Information for deciding whether a validator will be suspended the next snapshot epoch. + suspensionInfo :: !(Conditionally (SupportsValidatorSuspension av) SuspensionInfo) } deriving (Eq, Show) @@ -34,7 +56,7 @@ instance forall av. (IsAccountVersion av) => Serialize (BakerPoolRewardDetails a putWord64be blockCount put transactionFeesAccrued putBool finalizationAwake - mapM_ putWord64be missedRounds + mapM_ put suspensionInfo get = BakerPoolRewardDetails @@ -55,7 +77,8 @@ emptyBakerPoolRewardDetails = { blockCount = 0, transactionFeesAccrued = 0, finalizationAwake = False, - missedRounds = conditionally (sSupportsValidatorSuspension (accountVersion @av)) 0 + suspensionInfo = + conditionally (sSupportsValidatorSuspension (accountVersion @av)) emptySuspensionInfo } -- | Migrate BakerPoolRewardDetails with different account versions. @@ -66,9 +89,9 @@ migrateBakerPoolRewardDetails :: BakerPoolRewardDetails av1 migrateBakerPoolRewardDetails BakerPoolRewardDetails{..} = BakerPoolRewardDetails - { missedRounds = + { suspensionInfo = conditionally (sSupportsValidatorSuspension (accountVersion @av1)) - (fromCondDef missedRounds 0), + (fromCondDef suspensionInfo emptySuspensionInfo), .. } diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs index 477d76fa80..d9076182d4 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs @@ -9,6 +9,7 @@ module Concordium.KonsensusV1.Scheduler where import Control.Monad import Data.Bool.Singletons import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Time import Data.Word import Lens.Micro.Platform @@ -16,13 +17,15 @@ import Lens.Micro.Platform import Concordium.Logger import Concordium.TimeMonad import Concordium.Types +import Concordium.Types.Accounts (bakerIdentity) +import Concordium.Types.Conditionally import Concordium.Types.SeedState import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.CapitalDistribution import qualified Concordium.GlobalState.Persistent.BlockState as PBS -import Concordium.GlobalState.PoolRewards (BakerPoolRewardDetails) +import Concordium.GlobalState.PoolRewards (BakerPoolRewardDetails (..), SuspensionInfo (..), emptySuspensionInfo) import Concordium.GlobalState.TransactionTable import Concordium.GlobalState.Types import Concordium.KonsensusV1.LeaderElection @@ -117,7 +120,11 @@ data PrologueResult m av = PrologueResult prologueBlockState :: UpdatableBlockState m, -- | If the block should pay out for a payday, these parameters determine the pay out. -- Otherwise, they are 'Nothing'. - prologuePaydayParameters :: Maybe (PaydayParameters av) + prologuePaydayParameters :: Maybe (PaydayParameters av), + -- | If the block triggered an epoch transition and the new epoch is a + -- snapshot,this field contains the validator ids that are newly suspended. + -- Otherwise, this is `Nothing`. + prologueSuspendedBids :: Maybe (Set.Set BakerId) } -- * Block prologue @@ -147,6 +154,16 @@ paydayHandleCooldowns = case sSupportsFlexibleCooldown (sAccountVersionFor (prot let cooldownTime = triggerTime `addDurationSeconds` (cooldownParams ^. cpUnifiedCooldown) bsoProcessCooldowns theState0 triggerTime cooldownTime +-- | Result of the epoch transition used for parameter passing. +data EpochTransitionResult m = EpochTransitionResult + { -- If the epoch transition was a payday, this contains the payday + -- parameters. + mPaydayParams :: Maybe (PaydayParameters (AccountVersionFor (MPV m))), + -- If the epoch transition was a snapshot, this contains the set of + -- validator ids that will be newly suspended. + mSnapshotSuspendedIds :: Maybe (Set.Set BakerId) + } + -- | Update the state to reflect an epoch transition. If the block is not the first in a new epoch -- then this does nothing. Otherwise, it makes the following changes: -- @@ -186,8 +203,8 @@ doEpochTransition :: Duration -> -- | State to update UpdatableBlockState m -> - m (Maybe (PaydayParameters (AccountVersionFor (MPV m))), UpdatableBlockState m) -doEpochTransition False _ theState = return (Nothing, theState) + m (EpochTransitionResult m, UpdatableBlockState m) +doEpochTransition False _ theState = return (EpochTransitionResult Nothing Nothing, theState) doEpochTransition True epochDuration theState0 = do chainParams <- bsoGetChainParameters theState0 oldSeedState <- bsoGetSeedState theState0 @@ -225,9 +242,16 @@ doEpochTransition True epochDuration theState0 = do newBakers <- bsoGetCurrentEpochBakers theState6 let newSeedState = updateSeedStateForEpoch newBakers epochDuration oldSeedState theState7 <- bsoSetSeedState theState6 newSeedState - theState9 <- - if newEpoch + 1 == newNextPayday + let isSnapshot = newEpoch + 1 == newNextPayday + (suspendedBids, theState8) <- do + if isSnapshot then do + snapshotPoolRewards <- bsoGetBakerPoolRewardDetails theState7 + -- account indexes that will be suspended + let suspendedBids = + Set.fromList + [ bid | (bid, rd) <- Map.toList snapshotPoolRewards, primedForSuspension $ fromCondDef (suspensionInfo rd) emptySuspensionInfo + ] -- This is the start of the last epoch of a payday, so take a baker snapshot. let epochEnd = newSeedState ^. triggerBlockTime let av = accountVersionFor (demoteProtocolVersion (protocolVersion @(MPV m))) @@ -239,6 +263,7 @@ doEpochTransition True epochDuration theState0 = do (chainParams ^. cpPoolParameters) activeBakers passiveDelegators + suspendedBids theState8 <- bsoSetNextEpochBakers theState7 @@ -248,10 +273,10 @@ doEpochTransition True epochDuration theState0 = do -- From P7 onwards, we transition pre-pre-cooldowns into pre-cooldowns, so that -- at the next payday they will enter cooldown. case sSupportsFlexibleCooldown (sAccountVersionFor (protocolVersion @(MPV m))) of - STrue -> bsoProcessPrePreCooldowns theState9 - SFalse -> return theState9 - else return theState7 - return (mPaydayParams, theState9) + STrue -> (Just suspendedBids,) <$> bsoProcessPrePreCooldowns theState9 + SFalse -> return (Just suspendedBids, theState9) + else return (Nothing, theState7) + return (EpochTransitionResult mPaydayParams suspendedBids, theState8) -- | Update the seed state to account for a block. -- See 'updateSeedStateForBlock' for details of what this entails. @@ -303,13 +328,14 @@ executeBlockPrologue BlockExecutionData{..} = do -- unlock the scheduled releases that have expired theState3 <- bsoProcessReleaseSchedule theState2 bedTimestamp -- transition the epoch if necessary - (mPaydayParms, theState4) <- doEpochTransition bedIsNewEpoch bedEpochDuration theState3 + (EpochTransitionResult{..}, theState4) <- doEpochTransition bedIsNewEpoch bedEpochDuration theState3 -- update the seed state using the block time and block nonce theState5 <- doUpdateSeedStateForBlock bedTimestamp bedBlockNonce theState4 return PrologueResult { prologueBlockState = theState5, - prologuePaydayParameters = mPaydayParms + prologuePaydayParameters = mPaydayParams, + prologueSuspendedBids = mSnapshotSuspendedIds } -- * Block epilogue @@ -350,9 +376,11 @@ doMintingP6 mintRate foundationAddr theState0 = do -- | If a payday has elapsed, this mints and distributes rewards for the payday. processPaydayRewards :: + forall pv m. ( pv ~ MPV m, BlockStateStorage m, - IsConsensusV1 pv + IsConsensusV1 pv, + IsProtocolVersion pv ) => Maybe (PaydayParameters (AccountVersionFor (MPV m))) -> UpdatableBlockState m -> @@ -363,7 +391,18 @@ processPaydayRewards (Just PaydayParameters{..}) theState0 = do -- in which the rewards are distributed. foundationAddr <- getAccountCanonicalAddress =<< bsoGetFoundationAccount theState0 theState1 <- doMintingP6 paydayMintRate foundationAddr theState0 - distributeRewards foundationAddr paydayCapitalDistribution paydayBakers paydayPoolRewards theState1 + theState2 <- distributeRewards foundationAddr paydayCapitalDistribution paydayBakers paydayPoolRewards theState1 + case hasValidatorSuspension of + SFalse -> return theState2 + STrue -> do + cps <- bsoGetChainParameters theState1 + case _cpValidatorScoreParameters cps of + NoParam -> return theState1 + SomeParam (ValidatorScoreParameters{..}) -> do + (bids, theState3) <- bsoPrimeForSuspension theState2 _vspMaxMissedRounds (bakerInfoExs paydayBakers ^.. each . bakerIdentity) + foldM bsoAddSpecialTransactionOutcome theState3 (ValidatorPrimedForSuspension <$> bids) + where + hasValidatorSuspension = sSupportsValidatorSuspension (sAccountVersionFor (protocolVersion @pv)) -- | Records that the baker baked this block (so it is eligible for baking rewards) and that the -- finalizers that signed the QC in the block are awake (and eligible for finalizer rewards). @@ -402,10 +441,26 @@ processBlockRewards ParticipatingBakers{..} TransactionRewardParameters{..} miss where hasValidatorSuspension = sSupportsValidatorSuspension (sAccountVersionFor (protocolVersion @pv)) +-- | Suspend the given set of validators. Logs the suspension of a validator in +-- a special transaction outcome. +processSuspensions :: + forall pv m. + ( pv ~ MPV m, + BlockStateStorage m, + PVSupportsValidatorSuspension pv + ) => + Set.Set BakerId -> + UpdatableBlockState m -> + m (UpdatableBlockState m) +processSuspensions snapshotSuspendedBids bs0 = do + (ais', bs1) <- bsoSuspendValidators bs0 [ai | BakerId ai <- Set.toList snapshotSuspendedBids] + foldM bsoAddSpecialTransactionOutcome bs1 (ValidatorSuspended . BakerId <$> ais') + -- | Execute the block epilogue. This mints and distributes the rewards for a payday if the block is -- in a new payday. This also accrues the rewards for the block that will be paid at the next -- payday. executeBlockEpilogue :: + forall pv m. ( pv ~ MPV m, IsProtocolVersion pv, BlockStateStorage m, @@ -416,12 +471,20 @@ executeBlockEpilogue :: Maybe (PaydayParameters (AccountVersionFor (MPV m))) -> TransactionRewardParameters -> Map.Map BakerId Word64 -> + Maybe (Set.Set BakerId) -> UpdatableBlockState m -> m (PBS.HashedPersistentBlockState pv) -executeBlockEpilogue participants paydayParams transactionRewardParams missedRounds theState0 = do +executeBlockEpilogue participants paydayParams transactionRewardParams missedRounds snapshotSuspendedBids theState0 = do theState1 <- processPaydayRewards paydayParams theState0 theState2 <- processBlockRewards participants transactionRewardParams missedRounds theState1 - freezeBlockState theState2 + theState3 <- case hasValidatorSuspension of + STrue + | Just suspendedBids <- snapshotSuspendedBids -> processSuspensions suspendedBids theState2 + | otherwise -> return theState2 + SFalse -> return theState2 + freezeBlockState theState3 + where + hasValidatorSuspension = sSupportsValidatorSuspension (sAccountVersionFor (protocolVersion @pv)) -- * Transactions @@ -592,6 +655,7 @@ executeBlockState execData@BlockExecutionData{..} transactions = do prologuePaydayParameters terTransactionRewardParameters bedMissedRounds + prologueSuspendedBids terBlockState return (endState, terEnergyUsed) @@ -647,6 +711,7 @@ constructBlockState runtimeParams transactionTable pendingTable execData@BlockEx prologuePaydayParameters terTransactionRewardParameters bedMissedRounds + prologueSuspendedBids terBlockState endTime <- currentTime logEvent Scheduler LLInfo $ "Constructed a block in " ++ show (diffUTCTime endTime startTime) diff --git a/concordium-consensus/src/Concordium/Kontrol/Bakers.hs b/concordium-consensus/src/Concordium/Kontrol/Bakers.hs index af28d8dc2f..a211a8f0b0 100644 --- a/concordium-consensus/src/Concordium/Kontrol/Bakers.hs +++ b/concordium-consensus/src/Concordium/Kontrol/Bakers.hs @@ -12,6 +12,7 @@ module Concordium.Kontrol.Bakers where import Data.Maybe import Data.Monoid +import qualified Data.Set as Set import qualified Data.Vector as Vec import Lens.Micro.Platform @@ -178,8 +179,9 @@ computeBakerStakesAndCapital :: PoolParameters' 'PoolParametersVersion1 -> [ActiveBakerInfo' bakerInfoRef] -> [ActiveDelegatorInfo] -> + Set.Set BakerId -> BakerStakesAndCapital bakerInfoRef -computeBakerStakesAndCapital poolParams activeBakers passiveDelegators = BakerStakesAndCapital{..} +computeBakerStakesAndCapital poolParams activeBakers passiveDelegators snapshotSuspendedBids = BakerStakesAndCapital{..} where leverage = poolParams ^. ppLeverageBound capitalBound = poolParams ^. ppCapitalBound @@ -195,7 +197,7 @@ computeBakerStakesAndCapital poolParams activeBakers passiveDelegators = BakerSt capLimit ] ) - filteredActiveBakers = [abi | abi@ActiveBakerInfo{..} <- activeBakers, not activeBakerIsSuspended] + filteredActiveBakers = [abi | abi@ActiveBakerInfo{..} <- activeBakers, not (activeBakerIsSuspended || activeBakerId `Set.member` snapshotSuspendedBids)] filteredPoolCapitals = poolCapital <$> filteredActiveBakers bakerStakes = zipWith makeBakerStake filteredActiveBakers filteredPoolCapitals delegatorCapital ActiveDelegatorInfo{..} = DelegatorCapital activeDelegatorId activeDelegatorStake @@ -219,9 +221,10 @@ generateNextBakers :: ) => -- | The payday epoch Epoch -> + Set.Set BakerId -> UpdatableBlockState m -> m (UpdatableBlockState m) -generateNextBakers paydayEpoch bs0 = do +generateNextBakers paydayEpoch suspendedBids bs0 = do isEffective <- effectiveTest paydayEpoch -- Determine the bakers and delegators for the next reward period, accounting for any -- stake reductions that are currently pending on active bakers with effective time at @@ -241,6 +244,7 @@ generateNextBakers paydayEpoch bs0 = do (cps ^. cpPoolParameters) activeBakers passiveDelegators + suspendedBids bs1 <- bsoSetNextEpochBakers bs0 bakerStakes NoParam bsoSetNextCapitalDistribution bs1 capitalDistribution @@ -389,7 +393,7 @@ getSlotBakersP4 genData bs slot = ePoolParams pp' updates ePoolParams pp _ = pp effectivePoolParameters = ePoolParams (chainParams ^. cpPoolParameters) pendingPoolParams - bsc = computeBakerStakesAndCapital effectivePoolParameters activeBakers passiveDelegators + bsc = computeBakerStakesAndCapital effectivePoolParameters activeBakers passiveDelegators Set.empty let mkFullBaker (biRef, _bakerStake) = do _theBakerInfo <- derefBakerInfo biRef return FullBakerInfo{..} diff --git a/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs b/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs index 72438f0009..ecfb665b84 100644 --- a/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs @@ -20,6 +20,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Ratio import qualified Data.Sequence as Seq +import qualified Data.Set as Set import Data.Time import qualified Data.Vector as Vec import Data.Word @@ -1110,7 +1111,7 @@ updateBirkParameters newSeedState bs0 oldChainParameters updates = case protocol processPaydays pd mrps0 bspp0 = do bspp1 <- if oldSeedState ^. epoch < pd - 1 && pd - 1 <= newSeedState ^. epoch - then generateNextBakers pd bspp0 + then generateNextBakers pd Set.empty bspp0 else return bspp0 if pd <= newSeedState ^. epoch then do diff --git a/concordium-consensus/test-runners/app/Main.hs b/concordium-consensus/test-runners/app/Main.hs index c4bcece813..143eff4252 100644 --- a/concordium-consensus/test-runners/app/Main.hs +++ b/concordium-consensus/test-runners/app/Main.hs @@ -342,7 +342,8 @@ main = do PoolParametersV0 { _ppBakerStakeThreshold = 300000000000 }, - _cpFinalizationCommitteeParameters = NoParam + _cpFinalizationCommitteeParameters = NoParam, + _cpValidatorScoreParameters = NoParam } let (genesisData, bakerIdentities, _) = makeGenesisDataV0 @PV diff --git a/concordium-consensus/test-runners/catchup/Main.hs b/concordium-consensus/test-runners/catchup/Main.hs index 051251a2a1..15de0952f3 100644 --- a/concordium-consensus/test-runners/catchup/Main.hs +++ b/concordium-consensus/test-runners/catchup/Main.hs @@ -371,7 +371,8 @@ main = do PoolParametersV0 { _ppBakerStakeThreshold = 300000000000 }, - _cpFinalizationCommitteeParameters = NoParam + _cpFinalizationCommitteeParameters = NoParam, + _cpValidatorScoreParameters = NoParam } let (genesisData, bakerIdentities, _) = makeGenesisDataV0 @PV