sketch for auto suspension

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 #-}
 

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)

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)

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

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.