diff --git a/CHANGELOG.md b/CHANGELOG.md index 9de400395..b88ef5615 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,24 @@ ## Unreleased changes +## 7.0.3 + +- Fix a bug in the computation of the genesis height after the second protocol update. (#1237) +- Fix a bug where an error was incorrectly thrown when loading the consenus state immediately + after a protocol update (in the new consensus version) (#1236). + +## 7.0.2 + +- Fix the timing of paydays after protocol update from version 6 to 7. +- Improve consensus behaviour in the event of an unrecoverable exception. + +## 7.0.1 + +- Fix a bug in migration from protocol version 6 to 7. +- Support "reboot" protocol update at protocol version 7. + +## 7.0.0 + - Fix a bug where `GetBakersRewardPeriod` returns incorrect data (#1176). - Fix a bug where `GetPoolInfo` returns incorrect data (#1177). - Change the severity of logs for failed gRPC API requests to DEBUG level. @@ -20,6 +38,16 @@ `TransferToPublic` remains enabled, allowing existing encrypted balances to be decrypted. - Improve logging around protocol update events. +- Changes to stake cooldown behavior in protocol version 7: + - When stake is reduced or removed from a validator or delegator, it becomes + inactive, and is not counted for future stake calculations. The inactive + stake is not spendable, but is released after a cooldown period elapses. + - Changes to validators and delegators can be made while stake is in cooldown, + including changing the stake, or changing directly between validator and + delegator. +- Fix a bug where a configure-validator transaction that is rejected for having + a duplicate aggregation key would report the old key for the validator, + rather than the key that is a duplicate. ## 6.3.1 diff --git a/concordium-base b/concordium-base index 834a777f6..31a168d0a 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 834a777f6997fa7d53b26bcf8548322c22d66409 +Subproject commit 31a168d0af2c568e8e6dd7931a404601b2cee090 diff --git a/concordium-consensus/src-lib/Concordium/External.hs b/concordium-consensus/src-lib/Concordium/External.hs index dbe8c98d7..ef0ff94fb 100644 --- a/concordium-consensus/src-lib/Concordium/External.hs +++ b/concordium-consensus/src-lib/Concordium/External.hs @@ -726,7 +726,7 @@ stopBaker cptr = mask_ $ do -- | 16 | ResultNonexistingSenderAccount | The transaction's sender account does not exist according to the focus block | No | -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ -- | 17 | ResultDuplicateNonce | The sequence number for this account or update type was already used | No | --- i+-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ +-- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ -- | 18 | ResultNonceTooLarge | The transaction seq. number is larger than the next one for this account/update type | No | -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ -- | 19 | ResultTooLowEnergy | The stated transaction energy is lower than the minimum amount necessary to execute it | No | @@ -755,6 +755,8 @@ stopBaker cptr = mask_ $ do -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ -- | 31 | ResultDoubleSign | The consensus message is a result of malignant double signing. | No | -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ +-- | 32 | ResultConsensusFailure | The consensus has thrown an exception and entered an unrecoverable state. | No | +-- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ type ReceiveResult = Int64 -- | Convert an 'UpdateResult' to the corresponding 'ReceiveResult' value. @@ -791,12 +793,13 @@ toReceiveResult ResultChainUpdateInvalidSignatures = 28 toReceiveResult ResultEnergyExceeded = 29 toReceiveResult ResultInsufficientFunds = 30 toReceiveResult ResultDoubleSign = 31 +toReceiveResult ResultConsensusFailure = 32 -- | Handle receipt of a block. -- The possible return codes are @ResultSuccess@, @ResultSerializationFail@, -- @ResultInvalid@, @ResultPendingBlock@, @ResultDuplicate@, @ResultStale@, -- @ResultConsensusShutDown@, @ResultEarlyBlock@, @ResultInvalidGenesisIndex@, and --- @ResultDoubleSign@. +-- @ResultDoubleSign@. Additionally @ResultConsensusFailure@ is returned if an exception occurs. -- 'receiveBlock' may invoke the callbacks for new finalization messages. -- If the block was successfully verified i.e. baker signature, finalization proofs etc. then -- the continuation for executing the block will be written to the 'Ptr' provided. @@ -827,25 +830,27 @@ receiveBlock bptr genIndex msg msgLen ptrPtrExecuteBlock = do poke ptrPtrExecuteBlock =<< newStablePtr eb return $ toReceiveResult receiveResult --- | Execute a block that has been received and succesfully verified. +-- | Execute a block that has been received and successfully verified. -- The 'MV.ExecuteBlock' continuation is obtained via first calling 'receiveBlock' which in return -- will construct a pointer to the continuation. -- The 'StablePtr' is freed here and so this function should only be called once for each 'MV.ExecuteBlock'. -- The possible return codes are @ResultSuccess@, @ResultSerializationFail@, @ResultInvalid@ -- and @ResultConsensusShutDown@. +-- Additionally @ResultConsensusFailure@ is returned if an exception occurs. executeBlock :: StablePtr ConsensusRunner -> StablePtr MV.ExecuteBlock -> IO ReceiveResult executeBlock ptrConsensus ptrCont = do (ConsensusRunner mvr) <- deRefStablePtr ptrConsensus executableBlock <- deRefStablePtr ptrCont freeStablePtr ptrCont mvLog mvr External LLTrace "Executing block." - res <- MV.runBlock executableBlock + res <- runMVR (MV.executeBlock executableBlock) mvr return $ toReceiveResult res -- | Handle receipt of a finalization message. -- The possible return codes are @ResultSuccess@, @ResultSerializationFail@, @ResultInvalid@, -- @ResultPendingFinalization@, @ResultDuplicate@, @ResultStale@, @ResultIncorrectFinalizationSession@, -- @ResultUnverifiable@, @ResultConsensusShutDown@, @ResultInvalidGenesisIndex@, and @ResultDoubleSign@. +-- Additionally @ResultConsensusFailure@ is returned if an exception occurs. -- 'receiveFinalization' may invoke the callbacks for new finalization messages. receiveFinalizationMessage :: StablePtr ConsensusRunner -> @@ -863,6 +868,7 @@ receiveFinalizationMessage bptr genIndex msg msgLen = do -- The possible return codes are @ResultSuccess@, @ResultSerializationFail@, @ResultInvalid@, -- @ResultPendingBlock@, @ResultPendingFinalization@, @ResultDuplicate@, @ResultStale@, -- @ResultConsensusShutDown@ and @ResultInvalidGenesisIndex@. +-- Additionally @ResultConsensusFailure@ is returned if an exception occurs. -- 'receiveFinalizationRecord' may invoke the callbacks for new finalization messages. receiveFinalizationRecord :: StablePtr ConsensusRunner -> @@ -885,7 +891,8 @@ receiveFinalizationRecord bptr genIndex msg msgLen = do -- @ResultCredentialDeploymentInvalidIP@, @ResultCredentialDeploymentInvalidAR@, -- @ResultCredentialDeploymentExpired@, @ResultChainUpdateInvalidSequenceNumber@, -- @ResultChainUpdateInvalidEffectiveTime@, @ResultChainUpdateInvalidSignatures@, --- @ResultEnergyExceeded@ +-- @ResultEnergyExceeded@. +-- Additionally @ResultConsensusFailure@ is returned if an exception occurs. receiveTransaction :: StablePtr ConsensusRunner -> CString -> Int64 -> Ptr Word8 -> IO ReceiveResult receiveTransaction bptr transactionData transactionLen outPtr = do (ConsensusRunner mvr) <- deRefStablePtr bptr @@ -907,6 +914,7 @@ receiveTransaction bptr transactionData transactionLen outPtr = do -- * @ResultPendingBlock@ -- the sender has some data I am missing, and should be marked pending -- * @ResultSuccess@ -- I do not require additional data from the sender, so mark it as up-to-date -- * @ResultContinueCatchUp@ -- The sender should be marked pending if it is currently up-to-date (no change otherwise) +-- * @ResultConsensusFailure@ -- an internal exception occurred receiveCatchUpStatus :: -- | Consensus pointer StablePtr ConsensusRunner -> @@ -957,6 +965,7 @@ getCatchUpStatus cptr genIndexPtr resPtr = do -- | Import a file consisting of a set of blocks and finalization records for the purposes of -- out-of-band catch-up. +-- @ResultConsensusFailure@ is returned if an exception occurs. importBlocks :: -- | Consensus runner StablePtr ConsensusRunner -> diff --git a/concordium-consensus/src/Concordium/GlobalState/BakerInfo.hs b/concordium-consensus/src/Concordium/GlobalState/BakerInfo.hs index 97a5cb8fe..07d479bd6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BakerInfo.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BakerInfo.hs @@ -111,6 +111,15 @@ data BakerKeyUpdate = BakerKeyUpdate } deriving (Eq, Ord, Show) +-- | Extract the 'BakerKeyUpdate' from a 'BakerKeysWithProofs'. +bakerKeysWithoutProofs :: BakerKeysWithProofs -> BakerKeyUpdate +bakerKeysWithoutProofs BakerKeysWithProofs{..} = + BakerKeyUpdate + { bkuSignKey = bkwpSignatureVerifyKey, + bkuAggregationKey = bkwpAggregationVerifyKey, + bkuElectionKey = bkwpElectionVerifyKey + } + data BakerKeyUpdateResult = -- | The keys were updated successfully BKUSuccess !BakerId @@ -174,32 +183,83 @@ data BakerAddResult BAStakeUnderThreshold deriving (Eq, Ord, Show) --- | Data structure used to add/remove/update baker. -data BakerConfigure - = -- | Add a baker, all fields are required. - BakerConfigureAdd - { bcaKeys :: !BakerKeyUpdate, - bcaCapital :: !Amount, - bcaRestakeEarnings :: !Bool, - bcaOpenForDelegation :: !OpenStatus, - bcaMetadataURL :: !UrlText, - bcaTransactionFeeCommission :: !AmountFraction, - bcaBakingRewardCommission :: !AmountFraction, - bcaFinalizationRewardCommission :: !AmountFraction - } - | -- | Update baker with optional fields. - BakerConfigureUpdate - { -- | The timestamp of the current slot (slot time). - bcuSlotTimestamp :: !Timestamp, - bcuKeys :: !(Maybe BakerKeyUpdate), - bcuCapital :: !(Maybe Amount), - bcuRestakeEarnings :: !(Maybe Bool), - bcuOpenForDelegation :: !(Maybe OpenStatus), - bcuMetadataURL :: !(Maybe UrlText), - bcuTransactionFeeCommission :: !(Maybe AmountFraction), - bcuBakingRewardCommission :: !(Maybe AmountFraction), - bcuFinalizationRewardCommission :: !(Maybe AmountFraction) +-- | Result of remove baker. +data BakerRemoveResult + = -- | The baker was removed, effective from the given epoch. + BRRemoved !BakerId !Epoch + | -- | This is not a valid baker. + BRInvalidBaker + | -- | A change is already pending on this baker. + BRChangePending !BakerId + deriving (Eq, Ord, Show) + +-- | Parameters for adding a validator. +data ValidatorAdd = ValidatorAdd + { -- | The keys for the validator. + vaKeys :: !BakerKeyUpdate, + -- | The initial stake. + vaCapital :: !Amount, + -- | Whether to restake earned rewards + vaRestakeEarnings :: !Bool, + -- | Whether the validator pool is open for delegation. + vaOpenForDelegation :: !OpenStatus, + -- | The metadata URL for the validator. + vaMetadataURL :: !UrlText, + -- | The commission rates for the validator. + vaCommissionRates :: !CommissionRates + } + deriving (Eq, Show) + +-- | Parameters for updating an existing validator. Where a field is 'Nothing', the field is not +-- updated. +data ValidatorUpdate = ValidatorUpdate + { -- | The new keys for the validator. + vuKeys :: !(Maybe BakerKeyUpdate), + -- | The new capital for the validator. If this is @Just 0@, the validator is removed. + vuCapital :: !(Maybe Amount), + -- | Whether to restake earned rewards. + vuRestakeEarnings :: !(Maybe Bool), + -- | Whether the validator pool is open for delegation. + vuOpenForDelegation :: !(Maybe OpenStatus), + -- | The new metadata URL for the validator. + vuMetadataURL :: !(Maybe UrlText), + -- | The new transaction fee commission for the validator. + vuTransactionFeeCommission :: !(Maybe AmountFraction), + -- | The new baking reward commission for the validator. + vuBakingRewardCommission :: !(Maybe AmountFraction), + -- | The new finalization reward commission for the validator. + vuFinalizationRewardCommission :: !(Maybe AmountFraction) + } + deriving (Eq, Show) + +-- | A 'ValidatorUpdate' that removes the validator. +validatorRemove :: ValidatorUpdate +validatorRemove = + ValidatorUpdate + { vuKeys = Nothing, + vuCapital = Just 0, + vuRestakeEarnings = Nothing, + vuOpenForDelegation = Nothing, + vuMetadataURL = Nothing, + vuTransactionFeeCommission = Nothing, + vuBakingRewardCommission = Nothing, + vuFinalizationRewardCommission = Nothing } + +-- | Failure modes when configuring a validator. +data ValidatorConfigureFailure + = -- | The stake is below the required threshold dictated by current chain parameters. + VCFStakeUnderThreshold + | -- | The transaction fee commission is not in the allowed range. + VCFTransactionFeeCommissionNotInRange + | -- | The baking reward commission is not in the allowed range. + VCFBakingRewardCommissionNotInRange + | -- | The finalization reward commission is not in the allowed range. + VCFFinalizationRewardCommissionNotInRange + | -- | The aggregation key is already in use by another validator. + VCFDuplicateAggregationKey !BakerAggregationVerifyKey + | -- | A change is already pending on this validator. + VCFChangePending deriving (Eq, Show) -- | A baker update change result from configure baker. Used to indicate whether the configure will cause @@ -216,55 +276,37 @@ data BakerConfigureUpdateChange | BakerConfigureFinalizationRewardCommission !AmountFraction deriving (Eq, Show) --- | Result of configure baker. -data BakerConfigureResult - = -- | Configure baker successful. - BCSuccess ![BakerConfigureUpdateChange] !BakerId - | -- | Account unknown. - BCInvalidAccount - | -- | The aggregation key already exists. - BCDuplicateAggregationKey !BakerAggregationVerifyKey - | -- | The stake is below the required threshold dictated by current chain parameters. - BCStakeUnderThreshold - | -- | The finalization reward commission is not in the allowed range. - BCFinalizationRewardCommissionNotInRange - | -- | The baking reward commission is not in the allowed range. - BCBakingRewardCommissionNotInRange - | -- | The transaction fee commission is not in the allowed range. - BCTransactionFeeCommissionNotInRange - | -- | A change is already pending on this baker. - BCChangePending - | -- | This is not a valid baker. - BCInvalidBaker +-- | Parameters for adding a delegator. +data DelegatorAdd = DelegatorAdd + { -- | The initial staked capital for the delegator. + daCapital :: !Amount, + -- | Whether to restake earnings. + daRestakeEarnings :: !Bool, + -- | The delegation target for the delegator. + daDelegationTarget :: !DelegationTarget + } deriving (Eq, Show) --- | Result of remove baker. -data BakerRemoveResult - = -- | The baker was removed, effective from the given epoch. - BRRemoved !BakerId !Epoch - | -- | This is not a valid baker. - BRInvalidBaker - | -- | A change is already pending on this baker. - BRChangePending !BakerId - deriving (Eq, Ord, Show) +-- | Parameters for updating an existing delegator. Where a field is 'Nothing', the field is not +-- updated. +data DelegatorUpdate = DelegatorUpdate + { -- | The new capital for the delegator. If this is @Just 0@, the delegator is removed. + duCapital :: !(Maybe Amount), + -- | Whether to restake earnings. + duRestakeEarnings :: !(Maybe Bool), + -- | The new delegation target for the delegator. + duDelegationTarget :: !(Maybe DelegationTarget) + } + deriving (Eq, Show) --- | Data structure used to add/remove/update delegator. -data DelegationConfigure - = -- | Add a delegator, all fields are required. - DelegationConfigureAdd - { dcaCapital :: !Amount, - dcaRestakeEarnings :: !Bool, - dcaDelegationTarget :: !DelegationTarget - } - | -- | Update delegator with optional fields. - DelegationConfigureUpdate - { -- | The timestamp of the current slot (slot time of the block in which the update occurs). - dcuSlotTimestamp :: !Timestamp, - dcuCapital :: !(Maybe Amount), - dcuRestakeEarnings :: !(Maybe Bool), - dcuDelegationTarget :: !(Maybe DelegationTarget) +-- | A 'DelegatorUpdate' that removes the delegator. +delegatorRemove :: DelegatorUpdate +delegatorRemove = + DelegatorUpdate + { duCapital = Just 0, + duRestakeEarnings = Nothing, + duDelegationTarget = Nothing } - deriving (Eq, Show) -- | A delegation update change result from configure delegation. Used to indicate whether the -- configure will cause any changes to the delegator's stake, restake earnings flag, etc. @@ -275,24 +317,19 @@ data DelegationConfigureUpdateChange | DelegationConfigureDelegationTarget !DelegationTarget deriving (Eq, Show) --- | Result of configure delegator. -data DelegationConfigureResult - = -- | Configure delegation successful. - DCSuccess ![DelegationConfigureUpdateChange] !DelegatorId - | -- | Account unknown. - DCInvalidAccount - | -- | A change is already pending on this delegator. - DCChangePending - | -- | This is not a valid delegator. - DCInvalidDelegator - | -- | Delegation target is not a valid baker. - DCInvalidDelegationTarget !BakerId +-- | Failure modes for configuring a delegator. +data DelegatorConfigureFailure + = -- | The delegation target is not a valid baker. + DCFInvalidDelegationTarget !BakerId | -- | The pool is not open for delegators. - DCPoolClosed + DCFPoolClosed | -- | The pool's total capital would become too large. - DCPoolStakeOverThreshold - | -- | The delegated capital would become too large in comparison with pool owner's equity capital. - DCPoolOverDelegated + DCFPoolStakeOverThreshold + | -- | The delegated capital would become too large in comparison with pool owner's equity + -- capital. + DCFPoolOverDelegated + | -- | A change is already pending on this delegator. + DCFChangePending deriving (Eq, Show) -- | Construct an 'AccountBaker' from a 'GenesisBaker'. diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 16e9dc24c..b3034a13e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -975,10 +975,10 @@ class (BlockStateQuery m) => BlockStateOperations m where BakerAdd -> m (BakerAddResult, UpdatableBlockState m) - -- | From chain parameters version >= 1, this operation is used to add/remove/update a baker. - -- When adding baker, it is assumed that 'AccountIndex' account is NOT a baker and NOT a delegator. + -- | From chain parameters version >= 1, this adds a validator for an account. + -- + -- PRECONDITIONS: -- - -- When the argument is 'BakerConfigureAdd', the caller __must ensure__ that: -- * the account is valid; -- * the account is not a baker; -- * the account is not a delegator; @@ -986,82 +986,134 @@ class (BlockStateQuery m) => BlockStateOperations m where -- -- The function behaves as follows: -- - -- 1. If the account index is not valid, return 'BCInvalidAccount'. - -- 2. If the baker's capital is less than the minimum threshold, return 'BCStakeUnderThreshold'. - -- 3. If the transaction fee commission is not in the acceptable range, return - -- 'BCTransactionFeeCommissionNotInRange'. - -- 4. If the baking reward commission is not in the acceptable range, return - -- 'BCBakingRewardCommissionNotInRange'. - -- 5. If the finalization reward commission is not in the acceptable range, return - -- 'BCFinalizationRewardCommissionNotInRange'. - -- 6. If the aggregation key is a duplicate, return 'BCDuplicateAggregationKey'. - -- 7. Add the baker to the account, updating the indexes as follows: - -- * add an empty pool for the baker in the active bakers; - -- * add the baker's equity capital to the total active capital; - -- * add the baker's aggregation key to the aggregation key set. - -- 8. Return @BCSuccess []@. - -- - -- When the argument is 'BakerConfigureUpdate', the caller __must ensure__ that: + -- 1. If the baker's capital is 0, or less than the minimum threshold, return + -- 'VCFStakeUnderThreshold'. + -- 2. If the transaction fee commission is not in the acceptable range, return + -- 'VCFTransactionFeeCommissionNotInRange'. + -- 3. If the baking reward commission is not in the acceptable range, return + -- 'VCFBakingRewardCommissionNotInRange'. + -- 4. If the finalization reward commission is not in the acceptable range, return + -- 'VCFFinalizationRewardCommissionNotInRange'. + -- 5. If the aggregation key is a duplicate, return 'VCFDuplicateAggregationKey'. + -- 6. Add the baker to the account. If flexible cooldowns are supported by the protocol + -- version, then the capital in cooldown is reactivated. The indexes are updated as follows: + -- + -- * add an empty pool for the baker in the active bakers; + -- * add the baker's equity capital to the total active capital; + -- * add the baker's aggregation key to the aggregation key set; + -- * the cooldown indexes are updated to reflect any reactivation of capital. + -- + -- 7. Return the updated block state. + bsoAddValidator :: + (PVSupportsDelegation (MPV m)) => + UpdatableBlockState m -> + AccountIndex -> + ValidatorAdd -> + m (Either ValidatorConfigureFailure (UpdatableBlockState m)) + + -- | Update the validator for an account. + -- + -- PRECONDITIONS: + -- -- * the account is valid; -- * the account is a baker; - -- * if the stake is being updated, then the account balance exceeds the new stake. + -- * if the stake is being updated, then the account balance is at least the new stake. -- -- The function behaves as follows, building a list @events@: -- -- 1. If keys are supplied: if the aggregation key duplicates an existing aggregation key @key@ - -- (except this baker's current aggregation key), return @BCDuplicateAggregationKey key@; + -- (except the accounts's current aggregation key), return @VCFDuplicateAggregationKey key@; -- otherwise, update the keys with the supplied @keys@, update the aggregation key index -- (removing the old key and adding the new one), and append @BakerConfigureUpdateKeys keys@ -- to @events@. + -- -- 2. If the restake earnings flag is supplied: update the account's flag to the supplied value -- @restakeEarnings@ and append @BakerConfigureRestakeEarnings restakeEarnings@ to @events@. + -- -- 3. If the open-for-delegation configuration is supplied: - -- (1) update the account's configuration to the supplied value @openForDelegation@; - -- (2) if @openForDelegation == ClosedForAll@, transfer all delegators in the baker's pool to - -- passive delegation; and - -- (3) append @BakerConfigureOpenForDelegation openForDelegation@ to @events@. + -- + -- (1) update the account's configuration to the supplied value @openForDelegation@; + -- + -- (2) if @openForDelegation == ClosedForAll@, transfer all delegators in the baker's pool to + -- passive delegation; and + -- + -- (3) append @BakerConfigureOpenForDelegation openForDelegation@ to @events@. + -- -- 4. If the metadata URL is supplied: update the account's metadata URL to the supplied value -- @metadataURL@ and append @BakerConfigureMetadataURL metadataURL@ to @events@. + -- -- 5. If the transaction fee commission is supplied: - -- (1) if the commission does not fall within the current range according to the chain - -- parameters, return @BCTransactionFeeCommissionNotInRange@; otherwise, - -- (2) update the account's transaction fee commission rate to the the supplied value @tfc@; - -- (3) append @BakerConfigureTransactionFeeCommission tfc@ to @events@. + -- + -- (1) if the commission does not fall within the current range according to the chain + -- parameters, return @VCFTransactionFeeCommissionNotInRange@; otherwise, + -- + -- (2) update the account's transaction fee commission rate to the the supplied value @tfc@; + -- + -- (3) append @BakerConfigureTransactionFeeCommission tfc@ to @events@. + -- -- 6. If the baking reward commission is supplied: - -- (1) if the commission does not fall within the current range according to the chain - -- parameters, return @BCBakingRewardCommissionNotInRange@; otherwise, - -- (2) update the account's baking reward commission rate to the the supplied value @brc@; - -- (3) append @BakerConfigureBakingRewardCommission brc@ to @events@. + -- + -- (1) if the commission does not fall within the current range according to the chain + -- parameters, return @VCFBakingRewardCommissionNotInRange@; otherwise, + -- + -- (2) update the account's baking reward commission rate to the the supplied value @brc@; + -- + -- (3) append @BakerConfigureBakingRewardCommission brc@ to @events@. + -- -- 6. If the finalization reward commission is supplied: - -- (1) if the commission does not fall within the current range according to the chain - -- parameters, return @BCFinalizationRewardCommissionNotInRange@; otherwise, - -- (2) update the account's finalization reward commission rate to the the supplied value @frc@; - -- (3) append @BakerConfigureFinalizationRewardCommission frc@ to @events@. + -- + -- (1) if the commission does not fall within the current range according to the chain + -- parameters, return @VCFFinalizationRewardCommissionNotInRange@; otherwise, + -- + -- (2) update the account's finalization reward commission rate to the the supplied value @frc@; + -- + -- (3) append @BakerConfigureFinalizationRewardCommission frc@ to @events@. + -- -- 7. If the capital is supplied: if there is a pending change to the baker's capital, return - -- @BCChangePending@; otherwise: - -- * if the capital is 0, mark the baker as pending removal at @bcuSlotTimestamp@ plus the - -- the current baker cooldown period according to the chain parameters, and append - -- @BakerConfigureStakeReduced 0@ to @events@; - -- * if the capital is less than the current minimum equity capital, return @BCStakeUnderThreshold@; - -- * if the capital is (otherwise) less than the current equity capital of the baker, mark the - -- baker as pending stake reduction to the new capital at @bcuSlotTimestamp@ plus the - -- current baker cooldown period according to the chain parameters and append - -- @BakerConfigureStakeReduced capital@ to @events@; - -- * if the capital is equal to the baker's current equity capital, do nothing, append - -- @BakerConfigureStakeIncreased capital@ to @events@; - -- * if the capital is greater than the baker's current equity capital, increase the baker's - -- equity capital to the new capital (updating the total active capital in the active baker - -- index by adding the difference between the new and old capital) and append - -- @BakerConfigureStakeIncreased capital@ to @events@. - -- 8. return @BCSuccess events bid@, where @bid@ is the baker's ID. - -- - -- Note: in the case of an early return (i.e. not @BCSuccess@), the state is not updated. - bsoConfigureBaker :: + -- @VCFChangePending@; otherwise: + -- + -- * if the capital is 0 + -- + -- - (< P7) mark the baker as pending removal at @bcuSlotTimestamp@ plus the + -- the current baker cooldown period according to the chain parameters + -- + -- - (>= P7) transfer the existing staked capital to pre-pre-cooldown, and mark the + -- account as in pre-pre-cooldown (in the global index) if it wasn't already + -- + -- - append @BakerConfigureStakeReduced 0@ to @events@; + -- + -- * if the capital is less than the current minimum equity capital, return @BCStakeUnderThreshold@; + -- + -- * if the capital is (otherwise) less than the current equity capital of the baker + -- + -- - (< P7) mark the baker as pending stake reduction to the new capital at + -- @bcuSlotTimestamp@ plus the current baker cooldown period according to the chain + -- parameters + -- + -- - (>= P7) transfer the decrease in staked capital to pre-pre-cooldown, and mark the + -- account as in pre-pre-cooldown (in the global index) if it wasn't already + -- + -- - append @BakerConfigureStakeReduced capital@ to @events@; + -- + -- * if the capital is equal to the baker's current equity capital, do nothing, append + -- @BakerConfigureStakeIncreased capital@ to @events@; + -- + -- * if the capital is greater than the baker's current equity capital, increase the baker's + -- equity capital to the new capital (updating the total active capital in the active baker + -- index by adding the difference between the new and old capital) and append + -- @BakerConfigureStakeIncreased capital@ to @events@. From P7, the increase in stake + -- is (preferentially) reactivated from the inactive stake, updating the global indices + -- accordingly. + -- + -- 8. Return @events@ with the updated block state. + bsoUpdateValidator :: (PVSupportsDelegation (MPV m)) => UpdatableBlockState m -> + -- | Current timestamp of the block. + Timestamp -> AccountIndex -> - BakerConfigure -> - m (BakerConfigureResult, UpdatableBlockState m) + ValidatorUpdate -> + m (Either ValidatorConfigureFailure ([BakerConfigureUpdateChange], UpdatableBlockState m)) -- | Constrain the baker's commission rates to fall in the given ranges. -- If the account is invalid or not a baker, this does nothing. @@ -1072,32 +1124,51 @@ class (BlockStateQuery m) => BlockStateOperations m where CommissionRanges -> m (UpdatableBlockState m) - -- | From chain parameters version >= 1, this operation is used to add/remove/update a delegator. + -- | From chain parameters version >= 1, this operation is used to add a delegator. -- When adding delegator, it is assumed that 'AccountIndex' account is NOT a baker and NOT a delegator. -- - -- When the argument is 'DelegationConfigureAdd', the caller __must ensure__ that: + -- PRECONDITIONS: + -- -- * the account is valid; -- * the account is not a baker; -- * the account is not a delegator; - -- * the delegated amount does not exceed the account's balance. + -- * the delegated amount does not exceed the account's balance; + -- * the delegated stake is > 0. -- -- The function behaves as follows: -- - -- 1. If the delegation target is a valid baker that is not 'OpenForAll', return 'DCPoolClosed'. + -- 1. If the delegation target is a valid baker that is not 'OpenForAll', return 'DCFPoolClosed'. + -- -- 2. If the delegation target is baker id @bid@, but the baker does not exist, return - -- @DCInvalidDelegationTarget bid@. + -- @DCFInvalidDelegationTarget bid@. + -- -- 3. Update the active bakers index to record: - -- * the delegator delegates to the target pool; - -- * the target pool's delegated capital is increased by the delegated amount; - -- * the total active capital is increased by the delegated amount. + -- + -- * the delegator delegates to the target pool; + -- * the target pool's delegated capital is increased by the delegated amount; + -- * the total active capital is increased by the delegated amount. + -- -- 4. Update the account to record the specified delegation. + -- -- 5. If the amount delegated to the delegation target exceeds the leverage bound, return - -- 'DCPoolStakeOverThreshold' and revert any changes. + -- 'DCFPoolStakeOverThreshold' and revert any changes. + -- -- 6. If the amount delegated to the delegation target exceed the capital bound, return - -- 'DCPoolOverDelegated' and revert any changes. - -- 7. Return @DCSuccess []@ with the updated state. + -- 'DCFPoolOverDelegated' and revert any changes. + -- + -- 7. Return the updated state. + bsoAddDelegator :: + (PVSupportsDelegation (MPV m)) => + UpdatableBlockState m -> + AccountIndex -> + DelegatorAdd -> + m (Either DelegatorConfigureFailure (UpdatableBlockState m)) + + -- | From chain parameters version >= 1, this operation is used to update or remove a delegator. + -- It is assumed that the account is already a delegator. + -- + -- PRECONDITIONS: -- - -- When the argument is 'DelegationConfigureUpdate', the caller __must ensure__ that: -- * the account is valid; -- * the account is a delegator; -- * if the delegated amount is updated, it does not exceed the account's balance. @@ -1105,53 +1176,89 @@ class (BlockStateQuery m) => BlockStateOperations m where -- The function behaves as follows, building a list @events@: -- -- 1. If the delegation target is specified as @target@: - -- (1) If the delegation target is a valid baker that is not 'OpenForAll', return 'DCPoolClosed'. - -- (2) If the delegation target is baker id @bid@, but the baker does not exist, return - -- @DCInvalidDelegationTarget bid@. - -- (3) Update the active bakers index to: remove the delegator and delegated amount from the - -- old baker pool, and add the delegator and delegated amount to the new baker pool. - -- (Note, the total delegated amount is unchanged at this point.) - -- (4) Update the account to record the new delegation target. - -- (5) Append @DelegationConfigureDelegationTarget target@ to @events@. [N.B. if the target is - -- pool is the same as the previous value, steps (1)-(4) will do nothing and may be skipped - -- by the implementation. This relies on the invariant that delegators delegate only to - -- valid pools.] + -- + -- (1) If the delegation target is changed and is a valid baker that is not 'OpenForAll', + -- return 'DCFPoolClosed'. [Note, it is allowed for the target to be the same baker, + -- which is 'ClosedForNew'.] + -- + -- (2) If the delegation target is baker id @bid@, but the baker does not exist, return + -- @DCFInvalidDelegationTarget bid@. + -- + -- (3) Update the active bakers index to: remove the delegator and delegated amount from the + -- old baker pool, and add the delegator and delegated amount to the new baker pool. + -- (Note, the total delegated amount is unchanged at this point.) + -- + -- (4) Update the account to record the new delegation target. + -- + -- (5) Append @DelegationConfigureDelegationTarget target@ to @events@. [N.B. if the target is + -- pool is the same as the previous value, steps (1)-(4) will do nothing and may be skipped + -- by the implementation. This relies on the invariant that delegators delegate only to + -- valid pools.] + -- -- 2. If the "restake earnings" flag is specified as @restakeEarnings@: - -- (1) Update the restake earnings flag on the account to match @restakeEarnings@. - -- (2) Append @DelegationConfigureRestakeEarnings restakeEarnings@ to @events@. + -- + -- (1) Update the restake earnings flag on the account to match @restakeEarnings@. + -- + -- (2) Append @DelegationConfigureRestakeEarnings restakeEarnings@ to @events@. + -- -- 3. If the delegated capital is specified as @capital@: if there is a pending change to the - -- delegator's stake, return 'DCChangePending'; otherwise: - -- * If the new capital is 0, mark the delegator as pending removal at the slot timestamp - -- plus the delegator cooldown chain parameter, and append - -- @DelegationConfigureStakeReduced capital@ to @events@; otherwise - -- * If the the new capital is less than the current staked capital (but not 0), mark the - -- delegator as pending stake reduction to @capital@ at the slot timestamp plus the - -- delegator cooldown chain parameter, and append @DelegationConfigureStakeReduced capital@ - -- to @events@; - -- * If the new capital is equal to the current staked capital, append - -- @DelegationConfigureStakeIncreased capital@ to @events@. - -- * If the new capital is greater than the current staked capital by @delta > 0@: - -- * increase the total active capital by @delta@, - -- * increase the delegator's target pool delegated capital by @delta@, - -- * set the baker's delegated capital to @capital@, and - -- * append @DelegationConfigureStakeIncreased capital@ to @events@. - -- 4. If the amount delegated to the delegation target exceeds the leverage bound, return - -- 'DCPoolStakeOverThreshold' and revert any changes. - -- 5. If the amount delegated to the delegation target exceed the capital bound, return - -- 'DCPoolOverDelegated' and revert any changes. - -- 6. Return @DCSuccess events@ with the updated state. - -- - -- Note, if the return code is anything other than 'DCSuccess', the original state is returned. - -- If the preconditions are violated, the function may return 'DCInvalidAccount' (if the account - -- is not valid) or 'DCInvalidDelegator' (when updating, if the account is not a delegator). - -- However, this behaviour is not guaranteed, and could result in violations of the state - -- invariants. - bsoConfigureDelegation :: + -- delegator's stake, return 'DCFChangePending'; otherwise: + -- + -- * If the new capital is 0 + -- + -- - (< P7) mark the delegator as pending removal at the slot timestamp + -- plus the delegator cooldown chain parameter + -- + -- - (>= P7) remove the delegation record from the account, transfer the existing + -- staked capital to pre-pre-cooldown, and mark the account as in pre-pre-cooldown + -- (in the global index) if it wasn't already + -- + -- - append @DelegationConfigureStakeReduced capital@ to @events@; + -- + -- * If the the new capital is less than the current staked capital (but not 0), + -- + -- - (< P7) mark the delegator as pending stake reduction to @capital@ at the slot + -- timestamp plus the delegator cooldown chain parameter + -- + -- - (>= P7) transfer the decrease in staked capital to pre-pre-cooldown, and mark the + -- account as in pre-pre-cooldown (in the global index) if it wasn't already + -- + -- - append @DelegationConfigureStakeReduced capital@ to @events@; + -- + -- * If the new capital is equal to the current staked capital, append + -- @DelegationConfigureStakeIncreased capital@ to @events@. + -- + -- * If the new capital is greater than the current staked capital by @delta > 0@: + -- + -- * increase the total active capital by @delta@, + -- + -- * increase the delegator's target pool delegated capital by @delta@, + -- + -- * set the account's delegated capital to @capital@, + -- + -- * (>= P7) reactivate @delta@ from the account's inactive stake, removing the + -- account from the global cooldown indices if necessary, + -- + -- * append @DelegationConfigureStakeIncreased capital@ to @events@. + -- + -- 4. If the delegation target has changed (and the delegation was not immediately removed) or + -- the delegated capital is increased: + -- + -- * If the amount delegated to the delegation target exceeds the leverage bound, + -- return 'DCFPoolStakeOverThreshold' and revert any changes. + -- + -- * If the amount delegated to the delegation target exceed the capital bound, + -- return 'DCFPoolOverDelegated' and revert any changes. + -- + -- 6. Return @events@ with the updated state. + bsoUpdateDelegator :: (PVSupportsDelegation (MPV m)) => UpdatableBlockState m -> + -- | The current timestamp of the block. + Timestamp -> AccountIndex -> - DelegationConfigure -> - m (DelegationConfigureResult, UpdatableBlockState m) + DelegatorUpdate -> + m (Either DelegatorConfigureFailure ([DelegationConfigureUpdateChange], UpdatableBlockState m)) -- | Update the keys associated with an account. -- It is assumed that the keys have already been checked for validity/ownership as @@ -1396,6 +1503,18 @@ class (BlockStateQuery m) => BlockStateOperations m where -- | Get whether a protocol update is effective bsoIsProtocolUpdateEffective :: UpdatableBlockState m -> m Bool + -- | A snapshot of the block state that can be used to roll back to a previous state. + type StateSnapshot m + + -- | Take a snapshot of the block state that can be used to roll back to the state at the + -- snapshot. Note, if the state is restored then any 'UpdatableBlockState' that was derived + -- from the original state should be discarded. + -- This should be used with caution. + bsoSnapshotState :: UpdatableBlockState m -> m (StateSnapshot m) + + -- | Roll back to the state at the snapshot. This should be used with caution. + bsoRollback :: UpdatableBlockState m -> StateSnapshot m -> m (UpdatableBlockState m) + -- | Block state storage operations class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => BlockStateStorage m where -- | Derive a mutable state instance from a block state instance. The mutable @@ -1647,9 +1766,11 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat bsoGetCurrentEpochFullBakersEx = lift . bsoGetCurrentEpochFullBakersEx bsoGetCurrentCapitalDistribution = lift . bsoGetCurrentCapitalDistribution bsoAddBaker s addr a = lift $ bsoAddBaker s addr a - bsoConfigureBaker s aconfig a = lift $ bsoConfigureBaker s aconfig a + bsoAddValidator s ai a = lift $ bsoAddValidator s ai a + bsoUpdateValidator s ts ai upd = lift $ bsoUpdateValidator s ts ai upd bsoConstrainBakerCommission s acct ranges = lift $ bsoConstrainBakerCommission s acct ranges - bsoConfigureDelegation s aconfig a = lift $ bsoConfigureDelegation s aconfig a + bsoAddDelegator s ai a = lift $ bsoAddDelegator s ai a + bsoUpdateDelegator s ts ai a = lift $ bsoUpdateDelegator s ts ai a bsoUpdateBakerKeys s addr a = lift $ bsoUpdateBakerKeys s addr a bsoUpdateBakerStake s addr a = lift $ bsoUpdateBakerStake s addr a bsoUpdateBakerRestakeEarnings s addr a = lift $ bsoUpdateBakerRestakeEarnings s addr a @@ -1693,6 +1814,9 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat bsoGetBankStatus = lift . bsoGetBankStatus bsoSetRewardAccounts s = lift . bsoSetRewardAccounts s bsoIsProtocolUpdateEffective = lift . bsoIsProtocolUpdateEffective + type StateSnapshot (MGSTrans t m) = StateSnapshot m + bsoSnapshotState = lift . bsoSnapshotState + bsoRollback s = lift . bsoRollback s {-# INLINE bsoGetModule #-} {-# INLINE bsoGetAccount #-} {-# INLINE bsoGetAccountIndex #-} @@ -1711,7 +1835,10 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat {-# INLINE bsoSetSeedState #-} {-# INLINE bsoTransitionEpochBakers #-} {-# INLINE bsoAddBaker #-} - {-# INLINE bsoConfigureBaker #-} + {-# INLINE bsoAddValidator #-} + {-# INLINE bsoUpdateValidator #-} + {-# INLINE bsoAddDelegator #-} + {-# INLINE bsoUpdateDelegator #-} {-# INLINE bsoUpdateBakerKeys #-} {-# INLINE bsoUpdateBakerStake #-} {-# INLINE bsoUpdateBakerRestakeEarnings #-} @@ -1743,6 +1870,8 @@ instance (Monad (t m), MonadTrans t, BlockStateOperations m) => BlockStateOperat {-# INLINE bsoSetRewardAccounts #-} {-# INLINE bsoGetCurrentEpochBakers #-} {-# INLINE bsoIsProtocolUpdateEffective #-} + {-# INLINE bsoSnapshotState #-} + {-# INLINE bsoRollback #-} instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage (MGSTrans t m) where thawBlockState = lift . thawBlockState diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs index 437911c1c..6e5cc416c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs @@ -35,6 +35,7 @@ import qualified Concordium.GlobalState.Persistent.Account.StructureV1 as V1 import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.Cache import Concordium.GlobalState.Persistent.CachedRef +import Concordium.Logger -- * Account types @@ -723,7 +724,8 @@ migratePersistentAccount :: ( IsProtocolVersion oldpv, IsProtocolVersion pv, SupportMigration m t, - AccountMigration (AccountVersionFor pv) (t m) + AccountMigration (AccountVersionFor pv) (t m), + MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> PersistentAccount (AccountVersionFor oldpv) -> diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs index 5f37aa5fd..e7ccbfd1b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs @@ -19,6 +19,7 @@ import Data.Kind import Data.Maybe import Lens.Micro.Platform +import Concordium.Logger import Concordium.Types import Concordium.Types.Accounts import Concordium.Types.Conditionally @@ -178,7 +179,8 @@ newtype Monad, MonadState (AccountMigrationState oldpv pv), MonadIO, - LMDBAccountMap.MonadAccountMapStore + LMDBAccountMap.MonadAccountMapStore, + MonadLogger ) -- | Run an 'AccountMigrationStateTT' computation with the given initial state. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs index 58609ce33..e4ec2e0c4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- We suppress redundant constraint warnings since GHC does not detect when a constraint is used @@ -16,11 +18,13 @@ module Concordium.GlobalState.Persistent.Account.StructureV1 where import Control.Monad +import qualified Control.Monad.State.Class as State import Control.Monad.Trans -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.State.Strict as State (StateT (..)) import Data.Bits import Data.Bool.Singletons import Data.Foldable +import Data.Kind import qualified Data.Map.Strict as Map import Data.Serialize import Data.Word @@ -29,6 +33,7 @@ import Lens.Micro.Platform import qualified Concordium.Crypto.SHA256 as Hash import Concordium.Genesis.Data import Concordium.ID.Types hiding (values) +import Concordium.Logger import Concordium.Types import Concordium.Types.Accounts import Concordium.Types.Accounts.Releases @@ -207,8 +212,42 @@ migratePersistentAccountStakeEnduring PersistentAccountStakeEnduringBaker{..} = migratePersistentAccountStakeEnduring PersistentAccountStakeEnduringDelegator{..} = return $! PersistentAccountStakeEnduringDelegator{..} +-- | A monad transformer transformer that left-composes @StateT Amount@ +-- with a given monad transformer @t@. The purpose of this is to add state functionality for +-- tracking the current active stake on an account, which is used when migrating an account +-- between certain protocol versions. +-- +-- A monad transformer transformer is used so that the 'lift' operation removes both the +-- @StateT Amount@ and the underlying monad transformer @t@. This is important as the reference +-- migration functions depend on using 'lift' to access the source block state. +newtype StakedBalanceStateTT (t :: (Type -> Type) -> (Type -> Type)) (m :: Type -> Type) (a :: Type) = StakedBalanceStateTT + { runStakedBalanceStateTT' :: State.StateT Amount (t m) a + } + deriving newtype (Functor, Applicative, Monad, State.MonadState Amount, MonadIO, MonadLogger) + +-- | Run an 'StakedBalanceStateTT' computation with the given initial staked balance state. +runStakedBalanceStateTT :: StakedBalanceStateTT t m a -> Amount -> t m (a, Amount) +runStakedBalanceStateTT = State.runStateT . runStakedBalanceStateTT' + +instance (MonadTrans t) => MonadTrans (StakedBalanceStateTT t) where + lift = StakedBalanceStateTT . lift . lift + +deriving via + forall (t :: (Type -> Type) -> (Type -> Type)) (m :: Type -> Type). + State.StateT Amount (t m) + instance + (MonadBlobStore (t m)) => + MonadBlobStore (StakedBalanceStateTT t m) + +-- | Lift a computation in the base monad to the transformed monad. +liftStakedBalanceStateTT :: + (Monad (t m)) => + t m a -> + StakedBalanceStateTT t m a +liftStakedBalanceStateTT = StakedBalanceStateTT . lift + -- | Migrate a 'PersistentAccountStakeEnduring' from 'AccountV2' to 'AccountV3'. This runs in the --- 'StateT' monad, where the state is the amount of active stake on the account. +-- @StakedBalanceStateTT t m@ monad, where the state is the amount of active stake on the account. -- -- * If there is a pending change on the account, then the pending change is removed and the -- active stake is updated to apply the pending change. The change in the stake is moved to @@ -226,7 +265,7 @@ migratePersistentAccountStakeEnduringV2toV3 :: (SupportMigration m t, AccountMigration 'AccountV3 (t m)) => PersistentAccountStakeEnduring 'AccountV2 -> -- | Returns the new 'PersistentAccountStakeEnduring' and 'CooldownQueue'. - State.StateT Amount (t m) (PersistentAccountStakeEnduring 'AccountV3, CooldownQueue 'AccountV3) + StakedBalanceStateTT t m (PersistentAccountStakeEnduring 'AccountV3, CooldownQueue 'AccountV3) migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringNone = return (PersistentAccountStakeEnduringNone, emptyCooldownQueue) migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringBaker{..} = @@ -237,7 +276,7 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringBaker{ cooldownAmount <- State.get State.put 0 cooldown <- initialPrePreCooldownQueue cooldownAmount - lift addAccountInPrePreCooldown + liftStakedBalanceStateTT addAccountInPrePreCooldown return (PersistentAccountStakeEnduringNone, cooldown) ReduceStake newStake _ -> do oldStake <- State.get @@ -249,7 +288,7 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringBaker{ ++ show newStake State.put newStake cooldown <- initialPrePreCooldownQueue (oldStake - newStake) - lift addAccountInPrePreCooldown + liftStakedBalanceStateTT addAccountInPrePreCooldown newPASE <- keepBakerInfo return (newPASE, cooldown) NoChange -> (,emptyCooldownQueue) <$> keepBakerInfo @@ -269,13 +308,13 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringDelega cooldownAmount <- State.get State.put 0 cooldown <- initialPrePreCooldownQueue cooldownAmount - lift addAccountInPrePreCooldown + liftStakedBalanceStateTT addAccountInPrePreCooldown return (PersistentAccountStakeEnduringNone, cooldown) _ -> do newTarget <- case paseDelegatorTarget of DelegatePassive -> return DelegatePassive DelegateToBaker bid -> do - removed <- lift $ isBakerRemoved bid + removed <- liftStakedBalanceStateTT $ isBakerRemoved bid return $ if removed then DelegatePassive else paseDelegatorTarget let newDelegatorInfo = PersistentAccountStakeEnduringDelegator @@ -296,12 +335,12 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringDelega ++ show newStake State.put newStake cooldown <- initialPrePreCooldownQueue (oldStake - newStake) - lift $ do + liftStakedBalanceStateTT $ do addAccountInPrePreCooldown retainDelegator paseDelegatorId newStake newTarget return $!! (newDelegatorInfo, cooldown) NoChange -> do - lift $ retainDelegator paseDelegatorId oldStake newTarget + liftStakedBalanceStateTT $ retainDelegator paseDelegatorId oldStake newTarget return $!! (newDelegatorInfo, emptyCooldownQueue) -- | This relies on the fact that the 'AccountV2' hashing of 'AccountStake' is independent of the @@ -1843,7 +1882,7 @@ makeFromGenesisAccount spv cryptoParams chainParameters GenesisAccount{..} = do -- ** Migration migrateEnduringDataV2 :: - (SupportMigration m t) => + (SupportMigration m t, MonadLogger (t m)) => PersistentAccountEnduringData 'AccountV2 -> t m (PersistentAccountEnduringData 'AccountV2) migrateEnduringDataV2 ed = do @@ -1860,8 +1899,8 @@ migrateEnduringDataV2 ed = do .. } --- | Migrate enduring data from 'AccountV2' to 'AccountV3'. The 'Amount' in the 'State.StateT' --- represents the current active stake on the account. +-- | Migrate enduring data from 'AccountV2' to 'AccountV3'. This uses 'StakedBalanceStateTT' to +-- track the staked balance of the account. -- -- * If the account previously had a pending change, it will now have a pre-pre-cooldown, and -- 'addAccountInPrePreCooldown' is called (to register this globally). If the pending change @@ -1874,18 +1913,24 @@ migrateEnduringDataV2 ed = do -- * If the account is still delegating, 'retainDelegator' is called to record the (new) -- delegation amount and target globally. migrateEnduringDataV2toV3 :: - (SupportMigration m t, AccountMigration 'AccountV3 (t m)) => + (SupportMigration m t, AccountMigration 'AccountV3 (t m), MonadLogger (t m)) => -- | Current enduring data PersistentAccountEnduringData 'AccountV2 -> -- | New enduring data. - State.StateT Amount (t m) (PersistentAccountEnduringData 'AccountV3) + StakedBalanceStateTT t m (PersistentAccountEnduringData 'AccountV3) migrateEnduringDataV2toV3 ed = do + logEvent GlobalState LLTrace "Migrating persisting data" paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) - paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ migrateReference migratePersistentEncryptedAmount + paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ \e -> do + logEvent GlobalState LLTrace "Migrating encrypted amount" + migrateReference migratePersistentEncryptedAmount e paedReleaseSchedule <- forM (paedReleaseSchedule ed) $ \(oldRSRef, lockedAmt) -> do + logEvent GlobalState LLTrace "Migrating release schedule" newRSRef <- migrateReference migrateAccountReleaseSchedule oldRSRef return (newRSRef, lockedAmt) + logEvent GlobalState LLTrace "Migrating stake" (paedStake, paedStakeCooldown) <- migratePersistentAccountStakeEnduringV2toV3 (paedStake ed) + logEvent GlobalState LLTrace "Reconstructing account enduring data" makeAccountEnduringDataAV3 paedPersistingData paedEncryptedAmount @@ -1896,7 +1941,7 @@ migrateEnduringDataV2toV3 ed = do -- | Migration for 'PersistentAccountEnduringData'. Only supports 'AccountV3'. -- The data is unchanged in the migration. migrateEnduringDataV3toV3 :: - (SupportMigration m t) => + (SupportMigration m t, MonadLogger (t m)) => PersistentAccountEnduringData 'AccountV3 -> t m (PersistentAccountEnduringData 'AccountV3) migrateEnduringDataV3toV3 ed = do @@ -1930,7 +1975,8 @@ migrateEnduringDataV4toV4 ed = do migrateV2ToV2 :: ( MonadBlobStore m, MonadBlobStore (t m), - MonadTrans t + MonadTrans t, + MonadLogger (t m) ) => PersistentAccount 'AccountV2 -> t m (PersistentAccount 'AccountV2) @@ -1964,13 +2010,14 @@ migrateV2ToV3 :: ( MonadBlobStore m, MonadBlobStore (t m), AccountMigration 'AccountV3 (t m), - MonadTrans t + MonadTrans t, + MonadLogger (t m) ) => PersistentAccount 'AccountV2 -> t m (PersistentAccount 'AccountV3) migrateV2ToV3 acc = do (accountEnduringData, newStakedAmount) <- - State.runStateT + runStakedBalanceStateTT (migrateEagerBufferedRef migrateEnduringDataV2toV3 (accountEnduringData acc)) (accountStakedAmount acc) return $! @@ -1986,7 +2033,8 @@ migrateV2ToV3 acc = do migrateV3ToV3 :: ( MonadBlobStore m, MonadBlobStore (t m), - MonadTrans t + MonadTrans t, + MonadLogger (t m) ) => PersistentAccount 'AccountV3 -> t m (PersistentAccount 'AccountV3) @@ -2048,7 +2096,8 @@ migratePersistentAccount :: ( IsProtocolVersion oldpv, SupportMigration m t, AccountMigration (AccountVersionFor pv) (t m), - AccountStructureVersionFor (AccountVersionFor oldpv) ~ 'AccountStructureV1 + AccountStructureVersionFor (AccountVersionFor oldpv) ~ 'AccountStructureV1, + MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> PersistentAccount (AccountVersionFor oldpv) -> @@ -2066,7 +2115,8 @@ migratePersistentAccount StateMigrationParametersP7ToP8{} acc = migrateV3ToV4 ac migratePersistentAccountFromV0 :: ( SupportMigration m t, AccountVersionFor oldpv ~ 'AccountV1, - AccountVersionFor pv ~ 'AccountV2 + AccountVersionFor pv ~ 'AccountV2, + MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> V0.PersistentAccount (AccountVersionFor oldpv) -> diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 1061c63e7..198339807 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -75,6 +75,7 @@ import Concordium.GlobalState.Persistent.LFMBTree (LFMBTree', LFMBTreeHash, LFMB import qualified Concordium.GlobalState.Persistent.LFMBTree as L import qualified Concordium.GlobalState.Persistent.Trie as Trie import qualified Concordium.ID.Types as ID +import Concordium.Logger import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Option (Option (..)) @@ -420,6 +421,17 @@ updateAccountsAtIndex fupd ai a0@Accounts{..} = Nothing -> return (Nothing, a0) Just (res, act') -> return (Just res, a0{accountTable = act'}) +-- | Set the account at the given index. There must already be an account at the given index. +-- (If the account does not exist, this will throw an error.) +setAccountAtIndex :: (SupportsPersistentAccount pv m) => AccountIndex -> PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Accounts pv) +setAccountAtIndex ai newAcct a0@Accounts{..} = + L.update setUpdate ai accountTable >>= \case + Nothing -> error $ "setAccountAtIndex: no account at index " ++ show ai + Just (_, act') -> return (a0{accountTable = act'}) + where + -- Replace the old account with the new account, returning (). + setUpdate _ = return ((), newAcct) + -- | Perform an update to an account with the given index. -- Does nothing if the account does not exist. -- This should not be used to alter the address of an account (which is @@ -492,13 +504,17 @@ migrateAccounts :: SupportMigration m t, SupportsPersistentAccount oldpv m, SupportsPersistentAccount pv (t m), - AccountsMigration (AccountVersionFor pv) (t m) + AccountsMigration (AccountVersionFor pv) (t m), + MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> Accounts oldpv -> t m (Accounts pv) migrateAccounts migration Accounts{..} = do + logEvent GlobalState LLTrace "Migrating accounts" let migrateAccount acct = do + canonicalAddress <- accountCanonicalAddress =<< lift (refLoad acct) + logEvent GlobalState LLTrace $ "Migrating account: " <> show canonicalAddress newAcct <- migrateHashedCachedRef' (migratePersistentAccount migration) acct -- Increment the account index counter. nextAccount diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs index 23c74e602..bd063e7c1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs @@ -27,7 +27,6 @@ import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account -import qualified Concordium.GlobalState.Persistent.Accounts as Accounts import Concordium.GlobalState.Persistent.BlobStore import Concordium.Types import qualified Concordium.Types.Accounts as BaseAccounts @@ -37,6 +36,7 @@ import Concordium.Utils.Serialization import qualified Concordium.Crypto.SHA256 as H import Concordium.GlobalState.Basic.BlockState.LFMBTree (hashAsLFMBTV1) +import qualified Concordium.GlobalState.Persistent.Accounts as Accounts import qualified Concordium.GlobalState.Persistent.Trie as Trie import Concordium.Types.HashableTo import Concordium.Utils.Serialization.Put @@ -281,7 +281,16 @@ data PersistentActiveDelegators (av :: AccountVersion) where } -> PersistentActiveDelegators av --- | See documentation of @migratePersistentBlockState@. +-- | Lens to access the total capital of the delegators to the pool. +delegatorTotalCapital :: (AVSupportsDelegation av) => Lens' (PersistentActiveDelegators av) Amount +delegatorTotalCapital f (PersistentActiveDelegatorsV1{..}) = + (\newDTC -> PersistentActiveDelegatorsV1{adDelegatorTotalCapital = newDTC, ..}) + <$> f adDelegatorTotalCapital + +-- | Migrate the representation of a set of delegators to a particular pool. +-- In most cases, the migration is trivial, and the resulting structure is the same. +-- In the case of 'StateMigrationParametersP3ToP4', the set of delegators is introduced as empty, +-- and the total capital is introduced at 0. migratePersistentActiveDelegators :: (BlobStorable m (), BlobStorable (t m) (), MonadTrans t) => StateMigrationParameters oldpv pv -> @@ -394,17 +403,29 @@ tacAmount f (TotalActiveCapitalV1 amt) = TotalActiveCapitalV1 <$> f amt type AggregationKeySet = Trie.TrieN BufferedFix BakerAggregationVerifyKey () +-- | Persistent representation of the state of the active bakers and delegators. data PersistentActiveBakers (av :: AccountVersion) = PersistentActiveBakers - { _activeBakers :: !(BakerIdTrieMap av), + { -- | For each active baker, this records the set of delegators and their total stake. + -- (This does not include the baker's own stake.) + _activeBakers :: !(BakerIdTrieMap av), + -- | The set of aggregation keys of all active bakers. + -- This is used to prevent duplicate aggregation keys from being deployed. _aggregationKeys :: !AggregationKeySet, + -- | The set of delegators to the passive pool, with their total stake. _passiveDelegators :: !(PersistentActiveDelegators av), + -- | The total capital staked by all bakers and delegators. _totalActiveCapital :: !(TotalActiveCapital av) } deriving (Show) makeLenses ''PersistentActiveBakers --- | See documentation of @migratePersistentBlockState@. +-- | Migrate the representation of the active bakers and delegators on protocol update. +-- In most cases, the migration is trivial, and the resulting structure is the same. +-- The exception is migrating from P3 to P4 (where delegation is introduced), where +-- each pool's delegators are introduced as empty, and delegated capital is introduced at 0. +-- In that case, the total active capital is computed by summing the baker stake amounts +-- from the supplied accounts table. migratePersistentActiveBakers :: forall oldpv pv t m. ( IsProtocolVersion oldpv, @@ -422,7 +443,7 @@ migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do newAggregationKeys <- Trie.migrateTrieN True return _aggregationKeys newPassiveDelegators <- migratePersistentActiveDelegators migration _passiveDelegators bakerIds <- Trie.keysAsc newActiveBakers - totalStakedAmount <- + bakerStakedAmount <- foldM ( \acc (BakerId aid) -> Accounts.indexedAccount aid accounts >>= \case @@ -434,7 +455,7 @@ migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do ) 0 bakerIds - let newTotalActiveCapital = migrateTotalActiveCapital migration totalStakedAmount _totalActiveCapital + let newTotalActiveCapital = migrateTotalActiveCapital migration bakerStakedAmount _totalActiveCapital return PersistentActiveBakers { _activeBakers = newActiveBakers, @@ -503,6 +524,24 @@ addDelegator (DelegateToBaker bid) did amt pab = newActiveBakers <- Trie.insert bid pad' (pab ^. activeBakers) return $ Right $ pab & activeBakers .~ newActiveBakers +-- | Add a delegator to the persistent active bakers at a particular target. +-- It is assumed that the delegator is not already delegated to this target. +-- If the target is a baker, then the baker MUST be in the active bakers. +-- +-- IMPORTANT: This does not update the total active capital! +addDelegatorUnsafe :: + (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => + DelegationTarget -> + DelegatorId -> + Amount -> + PersistentActiveBakers av -> + m (PersistentActiveBakers av) +addDelegatorUnsafe DelegatePassive did amt = passiveDelegators (addDelegatorHelper did amt) +addDelegatorUnsafe (DelegateToBaker bid) did amt = activeBakers (fmap snd . Trie.adjust upd bid) + where + upd Nothing = error "addDelegatorUnsafe: Baker not found" + upd (Just pad) = ((),) . Trie.Insert <$> addDelegatorHelper did amt pad + -- | A helper function that removes a delegator from a 'PersistentActiveDelegators'. -- It is assumed that the delegator is in the delegators with the specified amount. removeDelegatorHelper :: @@ -535,6 +574,23 @@ removeDelegator (DelegateToBaker bid) did amt pab = do newActiveBakers <- snd <$> Trie.adjust rdh bid (pab ^. activeBakers) return $ pab & activeBakers .~ newActiveBakers +-- | Modify the total capital of a pool. The pool MUST already exist. +-- +-- IMPORTANT: This does not update the total active capital! +modifyPoolCapitalUnsafe :: + (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => + DelegationTarget -> + (Amount -> Amount) -> + PersistentActiveBakers av -> + m (PersistentActiveBakers av) +modifyPoolCapitalUnsafe DelegatePassive change = + pure . (passiveDelegators . delegatorTotalCapital %~ change) +modifyPoolCapitalUnsafe (DelegateToBaker bid) change = + activeBakers (fmap snd . Trie.adjust upd bid) + where + upd Nothing = error "modifyPoolCapitalUnsafe: Baker not found" + upd (Just pad) = pure . ((),) . Trie.Insert $ pad & delegatorTotalCapital %~ change + -- | Transfer all delegators from a baker to passive delegation in the 'PersistentActiveBakers'. This does -- not affect the total stake, and does not remove the baker itself. This returns the list of -- affected delegators. (This will have no effect if the baker is not actually a baker, although diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 8428f409e..b01095a17 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -373,7 +373,13 @@ readBlobBSFromHandle BlobStoreAccess{..} (BlobRef offset) = mask $ \restore -> d Right size | offset + 8 + size <= fromIntegral bhSize -> BS.hGet bhHandle (fromIntegral size) - _ -> throwIO $ userError "Attempted to read beyond the blob store end" + _ -> + throwIO $ + userError $ + "Attempted to read beyond the blob store end @" + ++ show offset + ++ " in file " + ++ blobStoreFilePath putMVar blobStoreFile bh{bhAtEnd = False} case eres :: Either SomeException BS.ByteString of Left e -> throwIO e diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 06b48e391..5edb0e8dc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -50,6 +51,7 @@ import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.CapitalDistribution import qualified Concordium.GlobalState.ContractStateV1 as StateV1 +import qualified Concordium.GlobalState.CooldownQueue as CooldownQueue import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.Account.CooldownQueue (NextCooldownChange (..)) @@ -76,7 +78,7 @@ import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.ID.Parameters as ID import qualified Concordium.ID.Types as ID import Concordium.Kontrol.Bakers -import Concordium.Logger (MonadLogger) +import Concordium.Logger import Concordium.TimeMonad (TimeMonad) import Concordium.Types import Concordium.Types.Accounts (AccountBaker (..)) @@ -86,6 +88,7 @@ import Concordium.Types.Execution (DelegationTarget (..), TransactionIndex, Tran import qualified Concordium.Types.Execution as Transactions import Concordium.Types.HashableTo import qualified Concordium.Types.IdentityProviders as IPS +import Concordium.Types.Option import Concordium.Types.Queries ( ActiveBakerPoolStatus (..), BakerPoolStatus (..), @@ -297,6 +300,14 @@ initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = -- Iterate the accounts again accumulate all relevant information. IBPFromAccountsAccum{..} <- foldM (accumFromAccounts ibpcdToBaker) initialIBPFromAccountsAccum accounts + -- The total stake from bakers and delegators + let totalStake = case delegationSupport @av of + SAVDelegationNotSupported -> aibpStakedTotal + SAVDelegationSupported -> + aibpStakedTotal + + sum ((^. delegatorTotalCapital) <$> ibpcdToBaker) + + ibpcdToPassive ^. delegatorTotalCapital + persistentActiveBakers <- refMake $! PersistentActiveBakers @@ -305,13 +316,13 @@ initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = _passiveDelegators = ibpcdToPassive, _totalActiveCapital = case delegationSupport @av of SAVDelegationNotSupported -> TotalActiveCapitalV0 - SAVDelegationSupported -> TotalActiveCapitalV1 aibpTotal + SAVDelegationSupported -> TotalActiveCapitalV1 totalStake } nextEpochBakers <- do _bakerInfos <- refMake $ BakerInfos aibpBakerInfoRefs _bakerStakes <- refMake $ BakerStakes aibpBakerStakes - refMake PersistentEpochBakers{_bakerTotalStake = aibpStakedTotal, ..} + refMake PersistentEpochBakers{_bakerTotalStake = totalStake, ..} return $! PersistentBirkParameters @@ -565,7 +576,9 @@ data BlockRewardDetails' (av :: AccountVersion) (bhv :: BlockHashVersion) where type BlockRewardDetails pv = BlockRewardDetails' (AccountVersionFor pv) (BlockHashVersionFor pv) -- | Migrate the block reward details. --- When migrating to a 'P4' or later, this sets the 'nextPaydayEpoch' to the reward period length. +-- When migrating to 'P4' or 'P5', or from 'P5' to 'P6', this sets the 'nextPaydayEpoch' to the +-- reward period length. Migrations from 'P6' onwards (consensus protocol version 1) will set the +-- 'nextPaydayEpoch' to occur at the same time as it would have before the protocol update. migrateBlockRewardDetails :: forall t m oldpv pv. ( MonadBlobStore (t m), @@ -590,11 +603,7 @@ migrateBlockRewardDetails StateMigrationParametersTrivial _ _ tp oldEpoch = \cas BlockRewardDetailsV1 <$> migrateHashedBufferedRef migratePR hbr where - rpLength = rewardPeriodEpochs _tpRewardPeriodLength - migratePR pr = migratePoolRewards nextPayday pr - where - oldPaydayEpoch = nextPaydayEpoch pr - nextPayday = max 1 (min rpLength (oldPaydayEpoch - oldEpoch)) + migratePR = migratePoolRewardsP6 oldEpoch _tpRewardPeriodLength NoParam -> case protocolVersion @pv of {} migrateBlockRewardDetails StateMigrationParametersP1P2 _ _ _ _ = \case (BlockRewardDetailsV0 heb) -> BlockRewardDetailsV0 <$> migrateHashedEpochBlocks heb @@ -613,10 +622,10 @@ migrateBlockRewardDetails StateMigrationParametersP5ToP6{} _ _ (SomeParam TimePa (BlockRewardDetailsV1 hbr) -> BlockRewardDetailsV1 <$> migrateHashedBufferedRef (migratePoolRewards (rewardPeriodEpochs _tpRewardPeriodLength)) hbr -migrateBlockRewardDetails StateMigrationParametersP6ToP7{} _ _ (SomeParam TimeParametersV1{..}) _ = \case +migrateBlockRewardDetails StateMigrationParametersP6ToP7{} _ _ (SomeParam TimeParametersV1{..}) oldEpoch = \case (BlockRewardDetailsV1 hbr) -> BlockRewardDetailsV1 - <$> migrateHashedBufferedRef (migratePoolRewards (rewardPeriodEpochs _tpRewardPeriodLength)) hbr + <$> migrateHashedBufferedRef (migratePoolRewardsP6 oldEpoch _tpRewardPeriodLength) hbr migrateBlockRewardDetails StateMigrationParametersP7ToP8{} _ _ (SomeParam TimeParametersV1{..}) _ = \case (BlockRewardDetailsV1 hbr) -> BlockRewardDetailsV1 @@ -1438,7 +1447,7 @@ doAddBaker pbs ai ba@BakerAdd{..} = do -- Account is not a baker | otherwise -> do cp <- (^. cpPoolParameters . ppBakerStakeThreshold) <$> lookupCurrentParameters (bspUpdates bsp) - if baStake < cp + if baStake < max 1 cp then return (BAStakeUnderThreshold, pbs) else do let bid = BakerId ai @@ -1485,245 +1494,524 @@ redelegatePassive accounts (DelegatorId accId) = accId accounts -doConfigureBaker :: +-- | Check the conditions required for successfully adding a validator. +-- This function does not modify the block state. +-- +-- The function behaves as follows: +-- +-- 1. If the baker's capital is 0, or less than the minimum threshold, throw +-- 'VCFStakeUnderThreshold'. +-- 2. If the transaction fee commission is not in the acceptable range, throw +-- 'VCFTransactionFeeCommissionNotInRange'. +-- 3. If the baking reward commission is not in the acceptable range, throw +-- 'VCFBakingRewardCommissionNotInRange'. +-- 4. If the finalization reward commission is not in the acceptable range, throw +-- 'VCFFinalizationRewardCommissionNotInRange'. +-- 5. If the aggregation key is a duplicate, throw 'VCFDuplicateAggregationKey'. +addValidatorChecks :: + forall pv m. + ( SupportsPersistentState pv m, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + BlockStatePointers pv -> + ValidatorAdd -> + MTL.ExceptT ValidatorConfigureFailure m () +addValidatorChecks bsp ValidatorAdd{..} = do + chainParams <- lookupCurrentParameters (bspUpdates bsp) + let + poolParams = chainParams ^. cpPoolParameters + capitalMin = poolParams ^. ppMinimumEquityCapital + ranges = poolParams ^. ppCommissionBounds + -- Check if the equity capital is below the minimum threshold. + when (vaCapital < max 1 capitalMin) $ MTL.throwError VCFStakeUnderThreshold + -- Check if the transaction fee commission rate is in the acceptable range. + unless + ( isInRange + (vaCommissionRates ^. transactionCommission) + (ranges ^. transactionCommissionRange) + ) + $ MTL.throwError VCFTransactionFeeCommissionNotInRange + -- Check if the baking reward commission rate is in the acceptable range. + unless + ( isInRange + (vaCommissionRates ^. bakingCommission) + (ranges ^. bakingCommissionRange) + ) + $ MTL.throwError VCFBakingRewardCommissionNotInRange + -- Check if the finalization reward commission rate is in the acceptable range. + unless + ( isInRange + (vaCommissionRates ^. finalizationCommission) + (ranges ^. finalizationCommissionRange) + ) + $ MTL.throwError VCFFinalizationRewardCommissionNotInRange + -- Check if the aggregation key is fresh. + pab <- refLoad $ bspBirkParameters bsp ^. birkActiveBakers + existingAggKey <- isJust <$> Trie.lookup (bkuAggregationKey vaKeys) (pab ^. aggregationKeys) + when existingAggKey $ + MTL.throwError (VCFDuplicateAggregationKey (bkuAggregationKey vaKeys)) + +-- | From chain parameters version >= 1, this adds a validator for an account. This is used to +-- implement 'bsoAddValidator'. +-- +-- PRECONDITIONS: +-- +-- * the account is valid; +-- * the account is not a baker; +-- * the account is not a delegator; +-- * the account has sufficient balance to cover the stake. +-- +-- The function behaves as follows: +-- +-- 1. If the baker's capital is 0, or less than the minimum threshold, return +-- 'VCFStakeUnderThreshold'. +-- 2. If the transaction fee commission is not in the acceptable range, return +-- 'VCFTransactionFeeCommissionNotInRange'. +-- 3. If the baking reward commission is not in the acceptable range, return +-- 'VCFBakingRewardCommissionNotInRange'. +-- 4. If the finalization reward commission is not in the acceptable range, return +-- 'VCFFinalizationRewardCommissionNotInRange'. +-- 5. If the aggregation key is a duplicate, return 'VCFDuplicateAggregationKey'. +-- 6. Add the baker to the account. If flexible cooldowns are supported by the protocol +-- version, then the capital in cooldown is reactivated. The indexes are updated as follows: +-- +-- * add an empty pool for the baker in the active bakers; +-- * add the baker's equity capital to the total active capital; +-- * add the baker's aggregation key to the aggregation key set; +-- * the cooldown indexes are updated to reflect any reactivation of capital. +-- +-- 7. Return the updated block state. +newAddValidator :: forall pv m. ( SupportsPersistentState pv m, PVSupportsDelegation pv, - SupportsFlexibleCooldown (AccountVersionFor pv) ~ 'False, -- FIXME: Flexible cooldown unimplemented IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState pv -> + PersistentBlockState (MPV m) -> AccountIndex -> - BakerConfigure -> - m (BakerConfigureResult, PersistentBlockState pv) -doConfigureBaker pbs ai BakerConfigureAdd{..} = do - -- It is assumed here that this account is NOT a baker and NOT a delegator. + ValidatorAdd -> + MTL.ExceptT ValidatorConfigureFailure m (PersistentBlockState (MPV m)) +newAddValidator pbs ai va@ValidatorAdd{..} = do bsp <- loadPBS pbs - Accounts.indexedAccount ai (bspAccounts bsp) >>= \case - -- Cannot resolve the account - Nothing -> return (BCInvalidAccount, pbs) - Just _ -> do - chainParams <- lookupCurrentParameters (bspUpdates bsp) - let poolParams = chainParams ^. cpPoolParameters - let capitalMin = poolParams ^. ppMinimumEquityCapital - let ranges = poolParams ^. ppCommissionBounds - if - | bcaCapital < capitalMin -> return (BCStakeUnderThreshold, pbs) - | not (isInRange bcaTransactionFeeCommission (ranges ^. transactionCommissionRange)) -> - return (BCTransactionFeeCommissionNotInRange, pbs) - | not (isInRange bcaBakingRewardCommission (ranges ^. bakingCommissionRange)) -> - return (BCBakingRewardCommissionNotInRange, pbs) - | not (isInRange bcaFinalizationRewardCommission (ranges ^. finalizationCommissionRange)) -> - return (BCFinalizationRewardCommissionNotInRange, pbs) - | otherwise -> do - let bid = BakerId ai - pab <- refLoad (_birkActiveBakers (bspBirkParameters bsp)) - let updAgg Nothing = return (True, Trie.Insert ()) - updAgg (Just ()) = return (False, Trie.NoChange) - Trie.adjust updAgg (bkuAggregationKey bcaKeys) (_aggregationKeys pab) >>= \case - -- Aggregation key is a duplicate - (False, _) -> return (BCDuplicateAggregationKey (bkuAggregationKey bcaKeys), pbs) - (True, newAggregationKeys) -> do - newActiveBakers <- Trie.insert bid emptyPersistentActiveDelegators (_activeBakers pab) - newpabref <- - refMake - PersistentActiveBakers - { _aggregationKeys = newAggregationKeys, - _activeBakers = newActiveBakers, - _passiveDelegators = pab ^. passiveDelegators, - _totalActiveCapital = addActiveCapital bcaCapital (_totalActiveCapital pab) - } - let newBirkParams = bspBirkParameters bsp & birkActiveBakers .~ newpabref - let cr = - CommissionRates - { _finalizationCommission = bcaFinalizationRewardCommission, - _bakingCommission = bcaBakingRewardCommission, - _transactionCommission = bcaTransactionFeeCommission - } - poolInfo = - BaseAccounts.BakerPoolInfo - { _poolOpenStatus = bcaOpenForDelegation, - _poolMetadataUrl = bcaMetadataURL, - _poolCommissionRates = cr - } - bakerInfo = bakerKeyUpdateToInfo bid bcaKeys - bakerInfoEx = - BaseAccounts.BakerInfoExV1 - { _bieBakerPoolInfo = poolInfo, - _bieBakerInfo = bakerInfo - } - updAcc = addAccountBakerV1 bakerInfoEx bcaCapital bcaRestakeEarnings - -- This cannot fail to update the account, since we already looked up the account. - newAccounts <- Accounts.updateAccountsAtIndex' updAcc ai (bspAccounts bsp) - (BCSuccess [] bid,) - <$> storePBS - pbs - bsp - { bspBirkParameters = newBirkParams, - bspAccounts = newAccounts - } -doConfigureBaker pbs ai BakerConfigureUpdate{..} = do - origBSP <- loadPBS pbs - cp <- lookupCurrentParameters (bspUpdates origBSP) - res <- MTL.runExceptT $ MTL.runWriterT $ flip MTL.execStateT origBSP $ do - baker <- getAccountOrFail - -- Check the various updates are OK, getting the transformation on the account - -- implied by each. - uKeys <- updateKeys baker - uRestake <- updateRestakeEarnings baker - uPoolInfo <- updateBakerPoolInfo baker cp - uCapital <- updateCapital baker cp - -- Compose together the transformations and apply them to the account. - let updAcc = uKeys >=> uRestake >=> uPoolInfo >=> uCapital - modifyAccount' updAcc - case res of - Left errorRes -> return (errorRes, pbs) - Right (newBSP, changes) -> (BCSuccess changes bid,) <$> storePBS pbs newBSP + addValidatorChecks bsp va + newBirkParams <- do + pab <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) + newAggregationKeys <- Trie.insert (bkuAggregationKey vaKeys) () (pab ^. aggregationKeys) + newActiveBakers <- Trie.insert bid emptyPersistentActiveDelegators (pab ^. activeBakers) + newPABref <- + refMake $ + pab + & aggregationKeys .~ newAggregationKeys + & activeBakers .~ newActiveBakers + & totalActiveCapital %~ addActiveCapital vaCapital + return $ bspBirkParameters bsp & birkActiveBakers .~ newPABref + let poolInfo = + BaseAccounts.BakerPoolInfo + { _poolOpenStatus = vaOpenForDelegation, + _poolMetadataUrl = vaMetadataURL, + _poolCommissionRates = vaCommissionRates + } + let bakerInfo = bakerKeyUpdateToInfo bid vaKeys + let bakerInfoEx = BaseAccounts.BakerInfoExV1 bakerInfo poolInfo + -- The precondition guaranties that the account exists + acc <- fromJust <$> Accounts.indexedAccount ai (bspAccounts bsp) + -- Add the baker to the account. + accWithBaker <- addAccountBakerV1 bakerInfoEx vaCapital vaRestakeEarnings acc + (accUpdated, newAIC) <- case flexibleCooldowns of + SFalse -> return (accWithBaker, bspAccountsInCooldown bsp) + STrue -> do + -- Reactivate stake in cooldown to cover the new stake. + oldCooldowns <- accountCooldowns accWithBaker + accUpdated <- reactivateCooldownAmount vaCapital accWithBaker + newCooldowns <- accountCooldowns accUpdated + let removals = cooldownRemovals oldCooldowns newCooldowns + newAIC <- applyCooldownRemovalsGlobally ai removals (bspAccountsInCooldown bsp) + return (accUpdated, newAIC) + newAccounts <- Accounts.setAccountAtIndex ai accUpdated (bspAccounts bsp) + storePBS pbs $ + bsp + { bspBirkParameters = newBirkParams, + bspAccounts = newAccounts, + bspAccountsInCooldown = newAIC + } + where + bid = BakerId ai + flexibleCooldowns = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) + +-- | Check the conditions required for successfully updating a validator. This does not modify +-- the block state. +-- +-- 1. If keys are supplied: if the aggregation key duplicates an existing aggregation key @key@ +-- (except the accounts's current aggregation key), throw @VCFDuplicateAggregationKey key@. +-- +-- 2. If the transaction fee commission is supplied, and the commission does not fall within the +-- current range according to the chain parameters, throw +-- @VCFTransactionFeeCommissionNotInRange@. +-- +-- 3. If the baking reward commission is supplied, and the commission does not fall within the +-- current range according to the chain parameters, throw @VCFBakingRewardCommissionNotInRange@. +-- +-- 4. If the finalization reward commission is supplied, and the commission does not fall within +-- the current range according to the chain parameters, throw +-- @VCFFinalizationRewardCommissionNotInRange@. +-- +-- 5. If the capital is supplied: +-- +-- * If there is a pending change to the baker's capital, throw @VCFChangePending@. +-- +-- * If the capital is non-zero, and less than the current minimum equity capital, throw +-- @BCStakeUnderThreshold@. +updateValidatorChecks :: + forall pv m. + ( SupportsPersistentState pv m, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + BlockStatePointers pv -> + -- | The current baker on the account being updated + AccountBaker (AccountVersionFor pv) -> + ValidatorUpdate -> + MTL.ExceptT ValidatorConfigureFailure m () +updateValidatorChecks bsp baker ValidatorUpdate{..} = do + chainParams <- lookupCurrentParameters (bspUpdates bsp) + let + poolParams = chainParams ^. cpPoolParameters + capitalMin = poolParams ^. ppMinimumEquityCapital + ranges = poolParams ^. ppCommissionBounds + -- Check if the aggregation key is fresh (or the same as the baker's existing one). + forM_ vuKeys $ \BakerKeyUpdate{..} -> + when (baker ^. BaseAccounts.bakerAggregationVerifyKey /= bkuAggregationKey) $ do + pab <- refLoad $ bspBirkParameters bsp ^. birkActiveBakers + existingAggKey <- isJust <$> Trie.lookup bkuAggregationKey (pab ^. aggregationKeys) + when existingAggKey $ MTL.throwError (VCFDuplicateAggregationKey bkuAggregationKey) + -- Check if the transaction fee commission rate is in the acceptable range. + forM_ vuTransactionFeeCommission $ \tfc -> + unless (isInRange tfc (ranges ^. transactionCommissionRange)) $ + MTL.throwError VCFTransactionFeeCommissionNotInRange + -- Check if the baking reward commission rate is in the acceptable range. + forM_ vuBakingRewardCommission $ \brc -> + unless (isInRange brc (ranges ^. bakingCommissionRange)) $ + MTL.throwError VCFBakingRewardCommissionNotInRange + -- Check if the finalization reward commission rate is in the acceptable range. + forM_ vuFinalizationRewardCommission $ \frc -> + unless (isInRange frc (ranges ^. finalizationCommissionRange)) $ + MTL.throwError VCFFinalizationRewardCommissionNotInRange + forM_ vuCapital $ \capital -> do + -- Check that there is no pending change on the account already. + when (baker ^. BaseAccounts.bakerPendingChange /= BaseAccounts.NoChange) $ + MTL.throwError VCFChangePending + -- Check that the baker's equity capital is above the minimum threshold, unless it + -- is being removed. + when (capital /= 0 && capital < capitalMin) $ + MTL.throwError VCFStakeUnderThreshold + +-- | Update the validator for an account. +-- +-- PRECONDITIONS: +-- +-- * the account is valid; +-- * the account is a baker; +-- * if the stake is being updated, then the account balance is at least the new stake. +-- +-- The function behaves as follows, building a list @events@: +-- +-- 1. If keys are supplied: if the aggregation key duplicates an existing aggregation key @key@ +-- (except the accounts's current aggregation key), return @VCFDuplicateAggregationKey key@; +-- otherwise, update the keys with the supplied @keys@, update the aggregation key index +-- (removing the old key and adding the new one), and append @BakerConfigureUpdateKeys keys@ +-- to @events@. +-- +-- 2. If the restake earnings flag is supplied: update the account's flag to the supplied value +-- @restakeEarnings@ and append @BakerConfigureRestakeEarnings restakeEarnings@ to @events@. +-- +-- 3. If the open-for-delegation configuration is supplied: +-- +-- (1) update the account's configuration to the supplied value @openForDelegation@; +-- +-- (2) if @openForDelegation == ClosedForAll@, transfer all delegators in the baker's pool to +-- passive delegation; and +-- +-- (3) append @BakerConfigureOpenForDelegation openForDelegation@ to @events@. +-- +-- 4. If the metadata URL is supplied: update the account's metadata URL to the supplied value +-- @metadataURL@ and append @BakerConfigureMetadataURL metadataURL@ to @events@. +-- +-- 5. If the transaction fee commission is supplied: +-- +-- (1) if the commission does not fall within the current range according to the chain +-- parameters, return @VCFTransactionFeeCommissionNotInRange@; otherwise, +-- +-- (2) update the account's transaction fee commission rate to the the supplied value @tfc@; +-- +-- (3) append @BakerConfigureTransactionFeeCommission tfc@ to @events@. +-- +-- 6. If the baking reward commission is supplied: +-- +-- (1) if the commission does not fall within the current range according to the chain +-- parameters, return @VCFBakingRewardCommissionNotInRange@; otherwise, +-- +-- (2) update the account's baking reward commission rate to the the supplied value @brc@; +-- +-- (3) append @BakerConfigureBakingRewardCommission brc@ to @events@. +-- +-- 7. If the finalization reward commission is supplied: +-- +-- (1) if the commission does not fall within the current range according to the chain +-- parameters, return @VCFFinalizationRewardCommissionNotInRange@; otherwise, +-- +-- (2) update the account's finalization reward commission rate to the the supplied value @frc@; +-- +-- (3) append @BakerConfigureFinalizationRewardCommission frc@ to @events@. +-- +-- 8. If the capital is supplied: if there is a pending change to the baker's capital, return +-- @VCFChangePending@; otherwise: +-- +-- * if the capital is 0 +-- +-- - (< P7) mark the baker as pending removal at @bcuSlotTimestamp@ plus the +-- the current baker cooldown period according to the chain parameters +-- +-- - (>= P7) transfer the existing staked capital to pre-pre-cooldown, and mark the +-- account as in pre-pre-cooldown (in the global index) if it wasn't already, and +-- update the active bakers index to reflect the change, including removing the baker's +-- aggregation key from the in-use set +-- +-- - append @BakerConfigureStakeReduced 0@ to @events@; +-- +-- * if the capital is less than the current minimum equity capital, return @BCStakeUnderThreshold@; +-- +-- * if the capital is (otherwise) less than the current equity capital of the baker +-- +-- - (< P7) mark the baker as pending stake reduction to the new capital at +-- @bcuSlotTimestamp@ plus the current baker cooldown period according to the chain +-- parameters +-- +-- - (>= P7) transfer the decrease in staked capital to pre-pre-cooldown, mark the +-- account as in pre-pre-cooldown (in the global index) if it wasn't already, and +-- update the active bakers index to reflect the change +-- +-- - append @BakerConfigureStakeReduced capital@ to @events@; +-- +-- * if the capital is equal to the baker's current equity capital, do nothing, append +-- @BakerConfigureStakeIncreased capital@ to @events@; +-- +-- * if the capital is greater than the baker's current equity capital, increase the baker's +-- equity capital to the new capital (updating the total active capital in the active baker +-- index by adding the difference between the new and old capital) and append +-- @BakerConfigureStakeIncreased capital@ to @events@. +-- +-- 9. Return @events@ with the updated block state. +newUpdateValidator :: + forall pv m. + ( SupportsPersistentState pv m, + PVSupportsDelegation pv, + IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, + CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 + ) => + PersistentBlockState (MPV m) -> + -- | Current block timestamp + Timestamp -> + AccountIndex -> + ValidatorUpdate -> + MTL.ExceptT ValidatorConfigureFailure m ([BakerConfigureUpdateChange], PersistentBlockState (MPV m)) +newUpdateValidator pbs curTimestamp ai vu@ValidatorUpdate{..} = do + bsp <- loadPBS pbs + -- Cannot fail: The precondition guaranties that the account exists + acc <- fromJust <$> Accounts.indexedAccount ai (bspAccounts bsp) + -- Cannot fail: account must be a registered baker. + existingBaker <- fromJust <$> accountBaker acc + updateValidatorChecks bsp existingBaker vu + (newBSP, events) <- lift . MTL.runWriterT $ do + (newBSP, newAcc) <- + updateKeys existingBaker (bsp, acc) + >>= updateRestakeEarnings + >>= updatePoolInfo existingBaker + >>= updateCapital existingBaker + newAccounts <- Accounts.setAccountAtIndex ai newAcc (bspAccounts newBSP) + return newBSP{bspAccounts = newAccounts} + (events,) <$> storePBS pbs newBSP where - -- Lift a monadic action over the ExceptT, WriterT and StateT layers. - liftBSO = lift . lift . lift bid = BakerId ai - getAccountOrFail :: MTL.StateT (BlockStatePointers pv) (MTL.WriterT [BakerConfigureUpdateChange] (MTL.ExceptT BakerConfigureResult m)) (AccountBaker (AccountVersionFor pv)) - getAccountOrFail = do - bsp <- MTL.get - liftBSO (Accounts.indexedAccount ai (bspAccounts bsp)) >>= \case - Nothing -> MTL.throwError BCInvalidAccount - Just acc -> - accountBaker acc >>= \case - Nothing -> MTL.throwError BCInvalidBaker - Just bkr -> return bkr - modifyAccount' updAcc = do - bsp <- MTL.get - newAccounts <- liftBSO $ Accounts.updateAccountsAtIndex' updAcc ai (bspAccounts bsp) - MTL.put bsp{bspAccounts = newAccounts} - ifPresent Nothing _ = return return + -- Only do the given update if specified. + ifPresent Nothing _ = return ifPresent (Just v) k = k v - updateKeys oldBkr = ifPresent bcuKeys $ \keys -> do - bsp <- MTL.get - pab <- liftBSO $ refLoad (_birkActiveBakers (bspBirkParameters bsp)) - let key = oldBkr ^. BaseAccounts.bakerAggregationVerifyKey - -- Try updating the aggregation keys - (keyOK, newAggregationKeys) <- - -- If the aggregation key has not changed, we have nothing to do. - if bkuAggregationKey keys == key - then return (True, _aggregationKeys pab) + updateKeys oldBaker = ifPresent vuKeys $ \keys (bsp, acc) -> do + let oldAggrKey = oldBaker ^. BaseAccounts.bakerAggregationVerifyKey + bsp1 <- + if bkuAggregationKey keys == oldAggrKey + then return bsp else do - -- Remove the old key - ak1 <- liftBSO $ Trie.delete key (_aggregationKeys pab) - -- Add the new key and check that it is not already present - let updAgg Nothing = return (True, Trie.Insert ()) - updAgg (Just ()) = return (False, Trie.NoChange) - liftBSO $ Trie.adjust updAgg (bkuAggregationKey keys) ak1 - unless keyOK (MTL.throwError (BCDuplicateAggregationKey key)) - newActiveBakers <- liftBSO $ refMake pab{_aggregationKeys = newAggregationKeys} - let newBirkParams = bspBirkParameters bsp & birkActiveBakers .~ newActiveBakers - MTL.modify' $ \s -> s{bspBirkParameters = newBirkParams} + pab <- refLoad $ bspBirkParameters bsp ^. birkActiveBakers + newAggregationKeys <- + Trie.insert (bkuAggregationKey keys) () + =<< Trie.delete oldAggrKey (pab ^. aggregationKeys) + newPABref <- refMake $ pab & aggregationKeys .~ newAggregationKeys + return $ + bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newPABref} + acc1 <- setAccountBakerKeys keys acc MTL.tell [BakerConfigureUpdateKeys keys] - -- Update the account with the new keys - return (setAccountBakerKeys keys) - updateRestakeEarnings oldBkr = ifPresent bcuRestakeEarnings $ \restakeEarnings -> do + return (bsp1, acc1) + updateRestakeEarnings = ifPresent vuRestakeEarnings $ \restakeEarnings (bsp, acc) -> do + acc1 <- setAccountRestakeEarnings restakeEarnings acc MTL.tell [BakerConfigureRestakeEarnings restakeEarnings] - if oldBkr ^. BaseAccounts.stakeEarnings == restakeEarnings - then return return - else return $ setAccountRestakeEarnings restakeEarnings - updateBakerPoolInfo :: - AccountBaker (AccountVersionFor pv) -> - ChainParameters pv -> - MTL.StateT - (BlockStatePointers pv) - ( MTL.WriterT - [BakerConfigureUpdateChange] - (MTL.ExceptT BakerConfigureResult m) - ) - (PersistentAccount (AccountVersionFor pv) -> m (PersistentAccount (AccountVersionFor pv))) - updateBakerPoolInfo oldBkr cp = do + return (bsp, acc1) + updatePoolInfo oldBaker (bsp0, acc) = do let pu0 = emptyBakerPoolInfoUpdate - pu1 <- condPoolInfoUpdate bcuOpenForDelegation (updateOpenForDelegation oldBkr) pu0 - pu2 <- condPoolInfoUpdate bcuMetadataURL (updateMetadataURL oldBkr) pu1 - pu3 <- condPoolInfoUpdate bcuTransactionFeeCommission (updateTransactionFeeCommission oldBkr cp) pu2 - pu4 <- condPoolInfoUpdate bcuBakingRewardCommission (updateBakingRewardCommission oldBkr cp) pu3 - pu5 <- condPoolInfoUpdate bcuFinalizationRewardCommission (updateFinalizationRewardCommission oldBkr cp) pu4 - return $ updateAccountBakerPoolInfo pu5 - condPoolInfoUpdate Nothing _ pu = return pu - condPoolInfoUpdate (Just x) a pu = a x pu - updateOpenForDelegation oldBkr openForDelegation pu = do + (bsp1, pu1) <- + updateOpenForDelegation oldBaker (bsp0, pu0) + >>= updateMetadataURL oldBaker + >>= updateTransactionFeeCommission oldBaker + >>= updateBakingRewardCommission oldBaker + >>= updateFinalizationRewardCommission oldBaker + acc1 <- updateAccountBakerPoolInfo pu1 acc + return (bsp1, acc1) + updateOpenForDelegation oldBaker = ifPresent vuOpenForDelegation $ \openForDelegation (bsp, pu) -> do MTL.tell [BakerConfigureOpenForDelegation openForDelegation] - if oldBkr ^. BaseAccounts.poolOpenStatus == openForDelegation - then return pu + if oldBaker ^. BaseAccounts.poolOpenStatus == openForDelegation + then return (bsp, pu) else do - when (openForDelegation == Transactions.ClosedForAll) $ do - -- Transfer all existing delegators to passive delegation. - birkParams <- MTL.gets bspBirkParameters - activeBkrs <- liftBSO $ refLoad (birkParams ^. birkActiveBakers) - -- Update the active bakers - (delegators, newActiveBkrs) <- transferDelegatorsToPassive bid activeBkrs - newActiveBkrsRef <- refMake newActiveBkrs - MTL.modify $ \bsp -> bsp{bspBirkParameters = birkParams & birkActiveBakers .~ newActiveBkrsRef} - -- Update each baker account - accts0 <- MTL.gets bspAccounts - accts1 <- foldM redelegatePassive accts0 delegators - MTL.modify $ \bsp -> bsp{bspAccounts = accts1} - return $! pu{updOpenForDelegation = Just openForDelegation} - updateMetadataURL oldBkr metadataURL pu = do - MTL.tell [BakerConfigureMetadataURL metadataURL] - if oldBkr ^. BaseAccounts.poolMetadataUrl == metadataURL - then return pu - else return $! pu{updMetadataURL = Just metadataURL} - updateTransactionFeeCommission oldBkr cp tfc pu = do - let range = cp ^. cpPoolParameters . ppCommissionBounds . transactionCommissionRange - unless (isInRange tfc range) (MTL.throwError BCTransactionFeeCommissionNotInRange) - MTL.tell [BakerConfigureTransactionFeeCommission tfc] - if oldBkr ^. BaseAccounts.poolCommissionRates . transactionCommission == tfc - then return pu - else return $! pu{updTransactionFeeCommission = Just tfc} - updateBakingRewardCommission oldBkr cp brc pu = do - let range = cp ^. cpPoolParameters . ppCommissionBounds . bakingCommissionRange - unless (isInRange brc range) (MTL.throwError BCBakingRewardCommissionNotInRange) - MTL.tell [BakerConfigureBakingRewardCommission brc] - if oldBkr ^. BaseAccounts.poolCommissionRates . bakingCommission == brc - then return pu - else return $! pu{updBakingRewardCommission = Just brc} - updateFinalizationRewardCommission oldBkr cp frc pu = do - let range = cp ^. cpPoolParameters . ppCommissionBounds . finalizationCommissionRange - unless (isInRange frc range) (MTL.throwError BCFinalizationRewardCommissionNotInRange) - MTL.tell [BakerConfigureFinalizationRewardCommission frc] - if oldBkr ^. BaseAccounts.poolCommissionRates . finalizationCommission == frc - then return pu - else return $! pu{updFinalizationRewardCommission = Just frc} - updateCapital oldBkr cp = ifPresent bcuCapital $ \capital -> do - when (_bakerPendingChange oldBkr /= BaseAccounts.NoChange) (MTL.throwError BCChangePending) - let capitalMin = cp ^. cpPoolParameters . ppMinimumEquityCapital + bsp1 <- + if openForDelegation == Transactions.ClosedForAll + then moveDelegatorsToPassive bsp Nothing + else return bsp + return (bsp1, pu{updOpenForDelegation = Just openForDelegation}) + updateMetadataURL oldBaker = ifPresent vuMetadataURL $ \metadataUrl (bsp, pu) -> do + MTL.tell [BakerConfigureMetadataURL metadataUrl] + if oldBaker ^. BaseAccounts.poolMetadataUrl == metadataUrl + then return (bsp, pu) + else return (bsp, pu{updMetadataURL = Just metadataUrl}) + updateTransactionFeeCommission oldBaker = + ifPresent vuTransactionFeeCommission $ \tfc (bsp, pu) -> do + MTL.tell [BakerConfigureTransactionFeeCommission tfc] + if oldBaker ^. BaseAccounts.poolCommissionRates . transactionCommission == tfc + then return (bsp, pu) + else return (bsp, pu{updTransactionFeeCommission = Just tfc}) + updateBakingRewardCommission oldBaker = + ifPresent vuBakingRewardCommission $ \brc (bsp, pu) -> do + MTL.tell [BakerConfigureBakingRewardCommission brc] + if oldBaker ^. BaseAccounts.poolCommissionRates . bakingCommission == brc + then return (bsp, pu) + else return (bsp, pu{updBakingRewardCommission = Just brc}) + updateFinalizationRewardCommission oldBaker = + ifPresent vuFinalizationRewardCommission $ \frc (bsp, pu) -> do + MTL.tell [BakerConfigureFinalizationRewardCommission frc] + if oldBaker ^. BaseAccounts.poolCommissionRates . finalizationCommission == frc + then return (bsp, pu) + else return (bsp, pu{updFinalizationRewardCommission = Just frc}) + updateCapital = updateCapital' (sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv))) + updateCapital' SFalse oldBaker = ifPresent vuCapital $ \capital (bsp, acc) -> do + -- No flexible cooldowns. Reducing stake creates a pending change. + cp <- lookupCurrentParameters (bspUpdates bsp) let cooldownDuration = cp ^. cpCooldownParameters . cpPoolOwnerCooldown - cooldownElapsed = addDurationSeconds bcuSlotTimestamp cooldownDuration + cooldownElapsed = + BaseAccounts.PendingChangeEffectiveV1 $ + addDurationSeconds curTimestamp cooldownDuration + let oldCapital = oldBaker ^. BaseAccounts.stakedAmount if capital == 0 then do - let bpc = BaseAccounts.RemoveStake (BaseAccounts.PendingChangeEffectiveV1 cooldownElapsed) + -- Validator is being removed. (Removal occurs after cooldown.) MTL.tell [BakerConfigureStakeReduced capital] - return $ setAccountStakePendingChange bpc - else do - when (capital < capitalMin) (MTL.throwError BCStakeUnderThreshold) - case compare capital (_stakedAmount oldBkr) of - LT -> do - let bpc = BaseAccounts.ReduceStake capital (BaseAccounts.PendingChangeEffectiveV1 cooldownElapsed) - MTL.tell [BakerConfigureStakeReduced capital] - return $ setAccountStakePendingChange bpc - EQ -> do - MTL.tell [BakerConfigureStakeIncreased capital] - return return - GT -> do - birkParams <- MTL.gets bspBirkParameters - activeBkrs <- liftBSO $ refLoad (birkParams ^. birkActiveBakers) - newActiveBkrs <- - liftBSO $ - refMake $ - activeBkrs - & totalActiveCapital - %~ addActiveCapital (capital - _stakedAmount oldBkr) - MTL.modify' $ \bsp -> bsp{bspBirkParameters = birkParams & birkActiveBakers .~ newActiveBkrs} - MTL.tell [BakerConfigureStakeIncreased capital] - return $ setAccountStake capital + let bpc = BaseAccounts.RemoveStake cooldownElapsed + (bsp,) <$> setAccountStakePendingChange bpc acc + else case compare capital oldCapital of + LT -> do + -- Stake reduced. + MTL.tell [BakerConfigureStakeReduced capital] + let bpc = BaseAccounts.ReduceStake capital cooldownElapsed + (bsp,) <$> setAccountStakePendingChange bpc acc + EQ -> do + -- Stake unchanged: record as if increased. + MTL.tell [BakerConfigureStakeIncreased capital] + return (bsp, acc) + GT -> do + -- Stake increased + MTL.tell [BakerConfigureStakeIncreased capital] + bsp1 <- + modifyActiveCapital + (addActiveCapital $ capital - oldCapital) + bsp + acc1 <- setAccountStake capital acc + return (bsp1, acc1) + updateCapital' STrue oldBaker = ifPresent vuCapital $ \capital (bsp, acc) -> do + -- Flexible cooldowns. Reducing stake goes into cooldown, and increasing stake reactivates + -- stake from cooldown. + let oldCapital = oldBaker ^. BaseAccounts.stakedAmount + if capital == 0 + then do + MTL.tell [BakerConfigureStakeReduced 0] + alreadyInPrePreCooldown <- accountHasPrePreCooldown acc + acc1 <- removeAccountStaking acc >>= addAccountPrePreCooldown oldCapital + let oldKeys = + maybe + (oldBaker ^. BaseAccounts.bakerAggregationVerifyKey) + bkuAggregationKey + vuKeys + bsp1 <- moveDelegatorsToPassive bsp (Just (oldCapital, oldKeys)) + bsp2 <- (if alreadyInPrePreCooldown then return else addToPrePreCooldowns) bsp1 + return (bsp2, acc1) + else case compare capital oldCapital of + LT -> do + MTL.tell [BakerConfigureStakeReduced capital] + alreadyInPrePreCooldown <- accountHasPrePreCooldown acc + acc1 <- + setAccountStake capital acc + >>= addAccountPrePreCooldown (oldCapital - capital) + bsp1 <- modifyActiveCapital (subtractActiveCapital $ oldCapital - capital) bsp + bsp2 <- (if alreadyInPrePreCooldown then return else addToPrePreCooldowns) bsp1 + return (bsp2, acc1) + EQ -> do + MTL.tell [BakerConfigureStakeIncreased capital] + return (bsp, acc) + GT -> do + MTL.tell [BakerConfigureStakeIncreased capital] + oldCooldowns <- accountCooldowns acc + acc1 <- + setAccountStake capital acc + >>= reactivateCooldownAmount (capital - oldCapital) + newCooldowns <- accountCooldowns acc1 + let removals = cooldownRemovals oldCooldowns newCooldowns + bsp1 <- modifyActiveCapital (addActiveCapital $ capital - oldCapital) bsp + newAIC <- applyCooldownRemovalsGlobally ai removals (bspAccountsInCooldown bsp1) + let bsp2 = bsp1{bspAccountsInCooldown = newAIC} + return (bsp2, acc1) + -- Move all @bid@'s current delegators into passive delegation. + -- If the amount (the baker's prior stake) and key (the bakers prior aggregation key) are + -- specified, then @bid@ is removed from the active bakers, the total active capital is reduced + -- accordingly, and the aggregation key is removed from the set of keys in use. + moveDelegatorsToPassive bsp mAmountAndKey = do + pab0 <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) + (delegators, pab1) <- transferDelegatorsToPassive bid pab0 + pab2 <- case mAmountAndKey of + Nothing -> return pab1 + Just (amount, aggKey) -> do + newActiveBakers <- Trie.delete bid (pab1 ^. activeBakers) + newAggregationKeys <- Trie.delete aggKey (pab1 ^. aggregationKeys) + return $ + pab1 + & totalActiveCapital %~ subtractActiveCapital amount + & activeBakers .~ newActiveBakers + & aggregationKeys .~ newAggregationKeys + newPABref <- refMake pab2 + let newBirkParams = bspBirkParameters bsp & birkActiveBakers .~ newPABref + newAccounts <- foldM redelegatePassive (bspAccounts bsp) delegators + return bsp{bspBirkParameters = newBirkParams, bspAccounts = newAccounts} + modifyActiveCapital upd bsp = do + pab <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) + newPABref <- refMake $ pab & totalActiveCapital %~ upd + return bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newPABref} + addToPrePreCooldowns :: + (MonadBlobStore m', PVSupportsFlexibleCooldown pv) => + BlockStatePointers pv -> + m' (BlockStatePointers pv) + addToPrePreCooldowns bsp = do + -- Add the account to the pre-pre-cooldowns list. + newAccountsInCooldown <- + (accountsInCooldown . prePreCooldown) + (consAccountList ai) + (bspAccountsInCooldown bsp) + return bsp{bspAccountsInCooldown = newAccountsInCooldown} doConstrainBakerCommission :: (SupportsPersistentState pv m, PVSupportsDelegation pv) => @@ -1752,220 +2040,501 @@ doConstrainBakerCommission pbs ai ranges = do updateFinalizationRewardCommission = finalizationCommission %~ (`closestInRange` (ranges ^. finalizationCommissionRange)) --- | Checks that the delegation target is not over-delegated. --- This can throw one of the following 'DelegationConfigureResult's, in order: +-- | Check the conditions required to successfully add a delegator to an account: -- --- * 'DCInvalidDelegationTarget' if the target baker is not a baker. --- * 'DCPoolStakeOverThreshold' if the delegated amount puts the pool over the leverage bound. --- * 'DCPoolOverDelegated' if the delegated amount puts the pool over the capital bound. -delegationConfigureDisallowOverdelegation :: - (IsProtocolVersion pv, PVSupportsDelegation pv, MTL.MonadError DelegationConfigureResult m, SupportsPersistentAccount pv m) => - BlockStatePointers pv -> - PoolParameters 'ChainParametersV1 -> - DelegationTarget -> - m () -delegationConfigureDisallowOverdelegation bsp poolParams target = case target of - Transactions.DelegatePassive -> return () - Transactions.DelegateToBaker bid@(BakerId baid) -> do - bakerEquityCapital <- - onAccount baid bsp accountBakerStakeAmount >>= \case - Just amt -> return amt - _ -> MTL.throwError (DCInvalidDelegationTarget bid) - capitalTotal <- totalCapital bsp - bakerDelegatedCapital <- poolDelegatorCapital bsp bid - let PoolCaps{..} = delegatedCapitalCaps poolParams capitalTotal bakerEquityCapital bakerDelegatedCapital - when (bakerDelegatedCapital > leverageCap) $ MTL.throwError DCPoolStakeOverThreshold - when (bakerDelegatedCapital > boundCap) $ MTL.throwError DCPoolOverDelegated - --- | Check that a delegation target is open for delegation. --- If the target is not a baker, this throws 'DCInvalidDelegationTarget'. --- If the target is not open for all, this throws 'DCPoolClosed'. -delegationCheckTargetOpen :: - (IsProtocolVersion pv, PVSupportsDelegation pv, MTL.MonadError DelegationConfigureResult m, SupportsPersistentAccount pv m) => +-- * the delegation target is passive delegation; or +-- +-- * the delegation target is a baker (otherwise, throw 'DCFInvalidDelegationTarget') and: +-- +-- - the baker's pool is open for all (otherwise, throw 'DCFPoolClosed'), +-- +-- - the delegation would not put the pool over the leverage bound (otherwise, throw +-- 'DCFPoolStakeOverThreshold'), and +-- +-- - the delegation would not put the pool over the capital bound (otherwise, throw +-- 'DCFPoolOverDelegated'). +addDelegatorChecks :: + ( IsProtocolVersion pv, + PVSupportsDelegation pv, + MTL.MonadError DelegatorConfigureFailure m, + SupportsPersistentAccount pv m, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => BlockStatePointers pv -> - DelegationTarget -> + DelegatorAdd -> m () -delegationCheckTargetOpen _ Transactions.DelegatePassive = return () -delegationCheckTargetOpen bsp (Transactions.DelegateToBaker bid@(BakerId baid)) = do +addDelegatorChecks _ DelegatorAdd{daDelegationTarget = Transactions.DelegatePassive} = return () +addDelegatorChecks bsp DelegatorAdd{daDelegationTarget = Transactions.DelegateToBaker bid, ..} = do onAccount baid bsp accountBaker >>= \case + Nothing -> MTL.throwError (DCFInvalidDelegationTarget bid) Just baker -> do - case baker ^. BaseAccounts.poolOpenStatus of - Transactions.OpenForAll -> return () - _ -> MTL.throwError DCPoolClosed - _ -> MTL.throwError (DCInvalidDelegationTarget bid) + unless (baker ^. BaseAccounts.poolOpenStatus == Transactions.OpenForAll) $ + MTL.throwError DCFPoolClosed + poolParams <- _cpPoolParameters <$> lookupCurrentParameters (bspUpdates bsp) + let bakerEquityCapital = baker ^. BaseAccounts.stakedAmount + bakerDelegatedCapital <- (daCapital +) <$> poolDelegatorCapital bsp bid + capitalTotal <- (daCapital +) <$> totalCapital bsp + let PoolCaps{..} = delegatedCapitalCaps poolParams capitalTotal bakerEquityCapital bakerDelegatedCapital + when (bakerDelegatedCapital > leverageCap) $ MTL.throwError DCFPoolStakeOverThreshold + when (bakerDelegatedCapital > boundCap) $ MTL.throwError DCFPoolOverDelegated + where + BakerId baid = bid -doConfigureDelegation :: +-- | From chain parameters version >= 1, this operation is used to add a delegator. +-- When adding delegator, it is assumed that 'AccountIndex' account is NOT a baker and NOT a delegator. +-- +-- PRECONDITIONS: +-- +-- * the account is valid; +-- * the account is not a baker; +-- * the account is not a delegator; +-- * the delegated amount does not exceed the account's balance; +-- * the delegated stake is > 0. +-- +-- The function behaves as follows: +-- +-- 1. If the delegation target is a valid baker that is not 'OpenForAll', return 'DCFPoolClosed'. +-- +-- 2. If the delegation target is baker id @bid@, but the baker does not exist, return +-- @DCFInvalidDelegationTarget bid@. +-- +-- 3. Update the active bakers index to record: +-- +-- * the delegator delegates to the target pool; +-- * the target pool's delegated capital is increased by the delegated amount; +-- * the total active capital is increased by the delegated amount. +-- +-- 4. Update the account to record the specified delegation. +-- +-- 5. If the amount delegated to the delegation target exceeds the leverage bound, return +-- 'DCFPoolStakeOverThreshold' and revert any changes. +-- +-- 6. If the amount delegated to the delegation target exceed the capital bound, return +-- 'DCFPoolOverDelegated' and revert any changes. +-- +-- 7. Return the updated state. +newAddDelegator :: forall pv m. ( SupportsPersistentState pv m, PVSupportsDelegation pv, - SupportsFlexibleCooldown (AccountVersionFor pv) ~ 'False, -- FIXME: Flexible cooldown unimplemented IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState pv -> + PersistentBlockState (MPV m) -> AccountIndex -> - DelegationConfigure -> - m (DelegationConfigureResult, PersistentBlockState pv) -doConfigureDelegation pbs ai DelegationConfigureAdd{..} = do - -- It is assumed here that this account is NOT a baker and NOT a delegator. - bsp <- loadPBS pbs - poolParams <- _cpPoolParameters <$> lookupCurrentParameters (bspUpdates bsp) - result <- MTL.runExceptT $ do - newBSP <- updateBlockState bsp - delegationConfigureDisallowOverdelegation newBSP poolParams dcaDelegationTarget - return newBSP - case result of - Left e -> return (e, pbs) - Right newBirkParams -> (DCSuccess [] did,) <$> storePBS pbs newBirkParams + DelegatorAdd -> + MTL.ExceptT DelegatorConfigureFailure m (PersistentBlockState (MPV m)) +newAddDelegator pbs ai da@DelegatorAdd{..} = do + bsp <- loadPBS pbs + addDelegatorChecks bsp da + newBirkParameters <- do + pab <- refLoad $ bspBirkParameters bsp ^. birkActiveBakers + -- Cannot fail: the delegation target is valid because it is checked in 'addDelegatorChecks'. + newActiveBakers <- + addDelegatorUnsafe daDelegationTarget did daCapital pab + <&> totalActiveCapital %~ addActiveCapital daCapital + newPABRef <- refMake newActiveBakers + return $ bspBirkParameters bsp & birkActiveBakers .~ newPABRef + case flexibleCooldown of + SFalse -> do + newAccounts <- + Accounts.updateAccountsAtIndex' + (addAccountDelegator newDelegator) + ai + (bspAccounts bsp) + storePBS pbs $ + bsp + { bspAccounts = newAccounts, + bspBirkParameters = newBirkParameters + } + STrue -> do + acc <- fromJust <$> Accounts.indexedAccount ai (bspAccounts bsp) + maybeCooldownsBefore <- accountCooldowns acc + newAcc <- (addAccountDelegator newDelegator >=> reactivateCooldownAmount daCapital) acc + maybeCooldownsAfter <- accountCooldowns newAcc + let removals = cooldownRemovals maybeCooldownsBefore maybeCooldownsAfter + newCooldowns <- applyCooldownRemovalsGlobally ai removals (bspAccountsInCooldown bsp) + newAccounts <- Accounts.setAccountAtIndex ai newAcc (bspAccounts bsp) + storePBS pbs $ + bsp + { bspAccounts = newAccounts, + bspBirkParameters = newBirkParameters, + bspAccountsInCooldown = newCooldowns + } where did = DelegatorId ai - updateBlockState bsp = - lift (Accounts.indexedAccount ai (bspAccounts bsp)) >>= \case - Nothing -> MTL.throwError DCInvalidAccount - Just _ -> do - delegationCheckTargetOpen bsp dcaDelegationTarget - newBirkParams <- updateBirk bsp dcaDelegationTarget - let dlg = - BaseAccounts.AccountDelegationV1 - { BaseAccounts._delegationIdentity = did, - BaseAccounts._delegationStakedAmount = dcaCapital, - BaseAccounts._delegationStakeEarnings = dcaRestakeEarnings, - BaseAccounts._delegationTarget = dcaDelegationTarget, - BaseAccounts._delegationPendingChange = BaseAccounts.NoChange - } - -- This cannot fail to update the accounts, since we already looked up the accounts: - newAccounts <- lift $ Accounts.updateAccountsAtIndex' (addAccountDelegator dlg) ai (bspAccounts bsp) - return bsp{bspBirkParameters = newBirkParams, bspAccounts = newAccounts} - updateBirk bsp Transactions.DelegatePassive = lift $ do - ab <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) - let PersistentActiveDelegatorsV1 dset tot = ab ^. passiveDelegators - newDset <- Trie.insert did () dset - newAB <- - refMake - ab - { _passiveDelegators = PersistentActiveDelegatorsV1 newDset (tot + dcaCapital), - _totalActiveCapital = addActiveCapital dcaCapital (_totalActiveCapital ab) - } - return $! bspBirkParameters bsp & birkActiveBakers .~ newAB - updateBirk bsp (Transactions.DelegateToBaker bid) = do - pab <- lift $ refLoad (bspBirkParameters bsp ^. birkActiveBakers) - mDels <- lift $ Trie.lookup bid (pab ^. activeBakers) - case mDels of - Nothing -> MTL.throwError (DCInvalidDelegationTarget bid) - Just (PersistentActiveDelegatorsV1 dels tot) -> do - newDels <- lift $ flip PersistentActiveDelegatorsV1 (tot + dcaCapital) <$> (Trie.insert did () dels) - newActiveBakers <- lift $ Trie.insert bid newDels (pab ^. activeBakers) - newpabref <- lift $ refMake pab{_activeBakers = newActiveBakers, _totalActiveCapital = addActiveCapital dcaCapital (_totalActiveCapital pab)} - return $! bspBirkParameters bsp & birkActiveBakers .~ newpabref -doConfigureDelegation pbs ai DelegationConfigureUpdate{..} = do - origBSP <- loadPBS pbs - cp <- lookupCurrentParameters (bspUpdates origBSP) - res <- MTL.runExceptT $ MTL.runWriterT $ flip MTL.execStateT origBSP $ do - oldTarget <- updateDelegationTarget - updateRestakeEarnings - oldCapital <- updateCapital cp - checkOverdelegation oldCapital oldTarget cp - case res of - Left errorRes -> return (errorRes, pbs) - Right (newBSP, changes) -> (DCSuccess changes did,) <$> storePBS pbs newBSP + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) + newDelegator :: BaseAccounts.AccountDelegation (AccountVersionFor pv) + newDelegator = + BaseAccounts.AccountDelegationV1 + { _delegationTarget = daDelegationTarget, + _delegationStakedAmount = daCapital, + _delegationStakeEarnings = daRestakeEarnings, + _delegationPendingChange = BaseAccounts.NoChange, + _delegationIdentity = did + } + +-- | Check the conditions required to successfully update a delegator. +-- +-- 1. If the delegation target is neither passive nor a valid baker, throw +-- 'DCFInvalidDelegationTarget'. +-- +-- 2. If the delegation target is a valid baker that is different from the previous target, but +-- the pool is not open for all, throw 'DCFPoolClosed'. +-- +-- 3. If the delegated capital is specified and there is a pending change to the delegator's +-- stake, throw 'DCFChangePending'. +-- +-- 4. If the delegation target is being changed or the delegated capital is being increased: +-- +-- * If the amount delegated to the delegation target would exceed the leverage bound, +-- throw 'DCFPoolStakeOverThreshold'. +-- +-- * If the amount delegated to the delegation target would exceed the capital bound, +-- throw 'DCFPoolOverDelegated'. +updateDelegatorChecks :: + forall pv m. + ( IsProtocolVersion pv, + PVSupportsDelegation pv, + MTL.MonadError DelegatorConfigureFailure m, + SupportsPersistentAccount pv m, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + BlockStatePointers pv -> + -- | The current delegation status of the account. + BaseAccounts.AccountDelegation (AccountVersionFor pv) -> + DelegatorUpdate -> + m () +updateDelegatorChecks bsp oldDelegator DelegatorUpdate{..} = do + -- Check that the delegation target is valid and open. + -- This returns @Just (baker, sameBaker)@ if the (new) delegation target is a baker (@baker@), + -- with @sameBaker@ indicating whether the delegator is still delegating to the same pool. + -- If the target is passive delegation, it returns @Nothing@. + mTargetBaker <- case duDelegationTarget of + Nothing -> case oldDelegator ^. BaseAccounts.delegationTarget of + Transactions.DelegatePassive -> return Nothing + Transactions.DelegateToBaker (BakerId baid) -> do + -- Cannot fail: the account is already delegating to a baker that can thus be looked up. + baker <- fromJust <$> onAccount baid bsp accountBaker + -- Since it wasn't changed, the baker is the same as before. + return (Just (baker, True)) + Just Transactions.DelegatePassive -> return Nothing + Just (Transactions.DelegateToBaker bid@(BakerId baid)) -> do + onAccount baid bsp accountBaker >>= \case + Nothing -> MTL.throwError (DCFInvalidDelegationTarget bid) + Just baker -> do + let sameBaker = + Transactions.DelegateToBaker bid + == oldDelegator ^. BaseAccounts.delegationTarget + unless + ( sameBaker + || baker ^. BaseAccounts.poolOpenStatus == Transactions.OpenForAll + ) + $ MTL.throwError DCFPoolClosed + return $ Just (baker, sameBaker) + -- If the capital is being changed, check there is not a pending change. + let hasPendingChange = + oldDelegator ^. BaseAccounts.delegationPendingChange /= BaseAccounts.NoChange + when (isJust duCapital && hasPendingChange) $ MTL.throwError DCFChangePending + -- If the target is a baker pool, check that the delegation amount is within bounds. + forM_ mTargetBaker $ \(baker, sameBaker) -> do + let oldStake = oldDelegator ^. BaseAccounts.delegationStakedAmount + -- The new effective stake is the old stake if: + -- - no new stake is provided, or + -- - the new stake is less than or equal to the old stake and the protocol version does + -- not support flexible cooldown. (In this case, the change will be pending on the + -- account.) + let newEffectiveStake = case duCapital of + Nothing -> oldStake + Just newStake -> case flexibleCooldown of + SFalse -> max newStake oldStake -- If the stake is reduced, the change is pending. + STrue -> newStake + -- We only check for over-delegation if the stake is being increased or the target is + -- is changed and the effective stake is non-zero. + unless (newEffectiveStake == 0 || sameBaker && newEffectiveStake <= oldStake) $ do + -- The change to the total staked capital. + let delta = newEffectiveStake `amountDiff` oldStake + -- The change to the pool's staked capital. This depends on whether the delegator is + -- switching pools. + let poolDelta = if sameBaker then delta else amountToDelta newEffectiveStake + poolParams <- _cpPoolParameters <$> lookupCurrentParameters (bspUpdates bsp) + let bakerEquityCapital = baker ^. BaseAccounts.stakedAmount + let bid = baker ^. BaseAccounts.bakerIdentity + bakerDelegatedCapital <- applyAmountDelta poolDelta <$> poolDelegatorCapital bsp bid + capitalTotal <- applyAmountDelta delta <$> totalCapital bsp + let PoolCaps{..} = + delegatedCapitalCaps poolParams capitalTotal bakerEquityCapital bakerDelegatedCapital + when (bakerDelegatedCapital > leverageCap) $ MTL.throwError DCFPoolStakeOverThreshold + when (bakerDelegatedCapital > boundCap) $ MTL.throwError DCFPoolOverDelegated + where + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) + +-- | From chain parameters version >= 1, this operation is used to update or remove a delegator. +-- This is used to implement 'bsoUpdateDelegator'. +-- +-- PRECONDITIONS: +-- +-- * the account is valid; +-- * the account is a delegator; +-- * if the delegated amount is updated, it does not exceed the account's balance. +-- +-- The function behaves as follows, building a list @events@: +-- +-- 1. If the delegation target is specified as @target@: +-- +-- (1) If the delegation target is changed and is a valid baker that is not 'OpenForAll', +-- return 'DCFPoolClosed'. [Note, it is allowed for the target to be the same baker, +-- which is 'ClosedForNew'.] +-- +-- (2) If the delegation target is baker id @bid@, but the baker does not exist, return +-- @DCFInvalidDelegationTarget bid@. +-- +-- (3) Update the active bakers index to: remove the delegator and delegated amount from the +-- old baker pool, and add the delegator and delegated amount to the new baker pool. +-- (Note, the total delegated amount is unchanged at this point.) +-- +-- (4) Update the account to record the new delegation target. +-- +-- (5) Append @DelegationConfigureDelegationTarget target@ to @events@. [N.B. if the target +-- pool is the same as the previous value, steps (1)-(4) will do nothing and may be skipped +-- by the implementation. This relies on the invariant that delegators delegate only to +-- valid pools.] +-- +-- 2. If the "restake earnings" flag is specified as @restakeEarnings@: +-- +-- (1) Update the restake earnings flag on the account to match @restakeEarnings@. +-- +-- (2) Append @DelegationConfigureRestakeEarnings restakeEarnings@ to @events@. +-- +-- 3. If the delegated capital is specified as @capital@: if there is a pending change to the +-- delegator's stake, return 'DCFChangePending'; otherwise: +-- +-- * If the new capital is 0, mark the delegator as pending removal at the slot timestamp +-- plus the delegator cooldown chain parameter, and append +-- @DelegationConfigureStakeReduced capital@ to @events@; otherwise +-- +-- * If the new capital is less than the current staked capital (but not 0), mark the +-- delegator as pending stake reduction to @capital@ at the slot timestamp plus the +-- delegator cooldown chain parameter, and append @DelegationConfigureStakeReduced capital@ +-- to @events@; +-- +-- * If the new capital is equal to the current staked capital, append +-- @DelegationConfigureStakeIncreased capital@ to @events@. +-- +-- * If the new capital is greater than the current staked capital by @delta > 0@: +-- +-- * increase the total active capital by @delta@, +-- +-- * increase the delegator's target pool delegated capital by @delta@, +-- +-- * set the baker's delegated capital to @capital@, and +-- +-- * append @DelegationConfigureStakeIncreased capital@ to @events@. +-- +-- 4. If the delegation target has changed or the delegated capital is increased: +-- +-- * If the amount delegated to the delegation target exceeds the leverage bound, +-- return 'DCFPoolStakeOverThreshold' and revert any changes. +-- +-- * If the amount delegated to the delegation target exceed the capital bound, +-- return 'DCFPoolOverDelegated' and revert any changes. +-- +-- 6. Return @events@ with the updated state. +newUpdateDelegator :: + forall pv m. + ( SupportsPersistentState pv m, + PVSupportsDelegation pv, + IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, + CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 + ) => + PersistentBlockState (MPV m) -> + -- | Current block timestamp + Timestamp -> + AccountIndex -> + DelegatorUpdate -> + MTL.ExceptT DelegatorConfigureFailure m ([DelegationConfigureUpdateChange], PersistentBlockState (MPV m)) +newUpdateDelegator pbs blockTimestamp ai du@DelegatorUpdate{..} = do + bsp <- loadPBS pbs + -- Cannot fail: The precondition guarantees that the account exists. + acc <- fromJust <$> Accounts.indexedAccount ai (bspAccounts bsp) + -- Cannot fail: the account must already be a delegator. + existingDelegator <- fromJust <$> accountDelegator acc + updateDelegatorChecks bsp existingDelegator du + (newBSP, events) <- lift . MTL.runWriterT $ do + (newBSP, newAcc) <- + updateDelegationTarget (existingDelegator ^. BaseAccounts.delegationTarget) (bsp, acc) + >>= updateRestakeEarnings + >>= updateCapital + + newAccounts <- Accounts.setAccountAtIndex ai newAcc (bspAccounts newBSP) + return newBSP{bspAccounts = newAccounts} + (events,) <$> storePBS pbs newBSP where did = DelegatorId ai - getAccountOrFail = do - bsp <- MTL.get - Accounts.indexedAccount ai (bspAccounts bsp) >>= \case - Nothing -> MTL.throwError DCInvalidAccount - Just acc -> - accountDelegator acc >>= \case - Just del -> return del - Nothing -> MTL.throwError DCInvalidDelegator - modifyAccount updAcc = do - bsp <- MTL.get - newAccounts <- Accounts.updateAccountsAtIndex' updAcc ai (bspAccounts bsp) - MTL.put - bsp - { bspAccounts = newAccounts - } - updateDelegationTarget = do - acctDlg <- getAccountOrFail - let oldTarget = acctDlg ^. BaseAccounts.delegationTarget - forM_ dcuDelegationTarget $ \target -> do - unless (oldTarget == target) $ do - -- Check that the target pool is open for delegation - bsp0 <- MTL.get - delegationCheckTargetOpen bsp0 target - ab <- refLoad =<< use (to bspBirkParameters . birkActiveBakers) - let stakedAmt = acctDlg ^. BaseAccounts.delegationStakedAmount - -- Transfer the delegator in the active bakers from the old target to the new one. - -- Note, these functions do not modify the total stake, but this is not being changed - -- - just moved. - ab1 <- removeDelegator oldTarget did stakedAmt ab - ab2 <- - addDelegator target did stakedAmt ab1 >>= \case - Left bid -> MTL.throwError (DCInvalidDelegationTarget bid) - Right ab2 -> return ab2 - newActiveBakers <- refMake ab2 - MTL.modify' $ \bsp -> bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newActiveBakers} - -- Update the account with the new delegation target. - modifyAccount (setAccountDelegationTarget target) - MTL.tell [DelegationConfigureDelegationTarget target] - return oldTarget - updateRestakeEarnings = forM_ dcuRestakeEarnings $ \restakeEarnings -> do - acctDlg <- getAccountOrFail - unless (acctDlg ^. BaseAccounts.delegationStakeEarnings == restakeEarnings) $ do - modifyAccount (setAccountRestakeEarnings restakeEarnings) + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) + -- Only do the update if specified. + ifPresent Nothing _ = return + ifPresent (Just v) k = k v + updateDelegationTarget oldTarget = ifPresent duDelegationTarget $ \target (bsp, acc) -> do + MTL.tell [DelegationConfigureDelegationTarget target] + stakedAmount <- accountActiveStakedAmount acc + if target == oldTarget || stakedAmount == 0 + then return (bsp, acc) + else do + bsp1 <- + onActiveBakers bsp $ + removeDelegator oldTarget did stakedAmount + >=> addDelegatorUnsafe target did stakedAmount + acc1 <- setAccountDelegationTarget target acc + return (bsp1, acc1) + updateRestakeEarnings = ifPresent duRestakeEarnings $ \restakeEarnings (bsp, acc) -> do MTL.tell [DelegationConfigureRestakeEarnings restakeEarnings] - updateCapital cp = do - ad <- getAccountOrFail - forM_ dcuCapital $ \capital -> do - when (BaseAccounts._delegationPendingChange ad /= BaseAccounts.NoChange) (MTL.throwError DCChangePending) - -- Cooldown time, used when the change reduces or removes the stake. - let cooldownDuration = cp ^. cpCooldownParameters . cpDelegatorCooldown - cooldownElapsed = addDurationSeconds dcuSlotTimestamp cooldownDuration + acc1 <- setAccountRestakeEarnings restakeEarnings acc + return (bsp, acc1) + updateCapital = ifPresent duCapital $ \capital (bsp, acc) -> case flexibleCooldown of + SFalse -> do + chainParams <- lookupCurrentParameters (bspUpdates bsp) + oldCapital <- accountActiveStakedAmount acc + let cooldownDuration = chainParams ^. cpCooldownParameters . cpDelegatorCooldown + cooldownElapsed = addDurationSeconds blockTimestamp cooldownDuration + changeEffective = BaseAccounts.PendingChangeEffectiveV1 cooldownElapsed if capital == 0 then do - let dpc = BaseAccounts.RemoveStake (BaseAccounts.PendingChangeEffectiveV1 cooldownElapsed) - modifyAccount $ setAccountStakePendingChange dpc MTL.tell [DelegationConfigureStakeReduced capital] - else case compare capital (BaseAccounts._delegationStakedAmount ad) of + let dpc = BaseAccounts.RemoveStake changeEffective + acc1 <- setAccountStakePendingChange dpc acc + return (bsp, acc1) + else case compare capital oldCapital of LT -> do - let dpc = BaseAccounts.ReduceStake capital (BaseAccounts.PendingChangeEffectiveV1 cooldownElapsed) - modifyAccount $ setAccountStakePendingChange dpc MTL.tell [DelegationConfigureStakeReduced capital] - EQ -> + let dpc = BaseAccounts.ReduceStake capital changeEffective + acc1 <- setAccountStakePendingChange dpc acc + return (bsp, acc1) + EQ -> do MTL.tell [DelegationConfigureStakeIncreased capital] + return (bsp, acc) GT -> do - bsp1 <- MTL.get - ab <- refLoad (bspBirkParameters bsp1 ^. birkActiveBakers) - newActiveBakers <- addTotalsInActiveBakers ab ad (capital - BaseAccounts._delegationStakedAmount ad) - MTL.modify' $ \bsp -> bsp{bspBirkParameters = bspBirkParameters bsp1 & birkActiveBakers .~ newActiveBakers} - modifyAccount $ setAccountStake capital MTL.tell [DelegationConfigureStakeIncreased capital] - return $ BaseAccounts._delegationStakedAmount ad - addTotalsInActiveBakers ab0 ad delta = do - let ab1 = ab0 & totalActiveCapital %~ addActiveCapital delta - case ad ^. BaseAccounts.delegationTarget of - Transactions.DelegatePassive -> do - let PersistentActiveDelegatorsV1 dset dtot = ab1 ^. passiveDelegators - refMake $! ab1 & passiveDelegators .~ PersistentActiveDelegatorsV1 dset (dtot + delta) - Transactions.DelegateToBaker bid -> do - Trie.lookup bid (ab1 ^. activeBakers) >>= \case - Nothing -> error "Invariant violation: delegation target is not an active baker" - Just (PersistentActiveDelegatorsV1 dset dtot) -> do - newActiveMap <- Trie.insert bid (PersistentActiveDelegatorsV1 dset (dtot + delta)) (ab1 ^. activeBakers) - refMake $! ab1 & activeBakers .~ newActiveMap - checkOverdelegation oldCapital oldTarget cp = do - let doCheckOverDelegation = do - let pp = cp ^. cpPoolParameters - ad <- getAccountOrFail - let target = ad ^. BaseAccounts.delegationTarget - bsp <- MTL.get - delegationConfigureDisallowOverdelegation bsp pp target - case (dcuCapital, dcuDelegationTarget) of - (Just newCapital, Just newTarget) -> unless (newCapital <= oldCapital && newTarget == oldTarget) doCheckOverDelegation - (Just newCapital, Nothing) -> unless (newCapital <= oldCapital) doCheckOverDelegation - (Nothing, Just newTarget) -> unless (newTarget == oldTarget) doCheckOverDelegation - _ -> return () + -- Cannot fail: account must already be a delegator. + target <- BaseAccounts._delegationTarget . fromJust <$> accountDelegator acc + let change = capital - oldCapital + bsp1 <- + onActiveBakers bsp $ + fmap (totalActiveCapital %~ addActiveCapital change) + . modifyPoolCapitalUnsafe target (+ change) + acc1 <- setAccountStake capital acc + return (bsp1, acc1) + STrue -> do + oldCapital <- accountActiveStakedAmount acc + target <- BaseAccounts._delegationTarget . fromJust <$> accountDelegator acc + if capital == 0 + then do + MTL.tell [DelegationConfigureStakeReduced 0] + bsp1 <- + onActiveBakers bsp $ + removeDelegator target did oldCapital + . (totalActiveCapital %~ subtractActiveCapital oldCapital) + + alreadyInPrePreCooldown <- accountHasPrePreCooldown acc + acc1 <- removeAccountStaking acc >>= addAccountPrePreCooldown oldCapital + bsp2 <- (if alreadyInPrePreCooldown then return else addToPrePreCooldowns) bsp1 + return (bsp2, acc1) + else case compare capital oldCapital of + LT -> do + MTL.tell [DelegationConfigureStakeReduced capital] + let delta = oldCapital - capital + bsp1 <- + onActiveBakers bsp $ + fmap (totalActiveCapital %~ subtractActiveCapital delta) + . modifyPoolCapitalUnsafe target (subtract delta) + alreadyInPrePreCooldown <- accountHasPrePreCooldown acc + acc1 <- setAccountStake capital acc >>= addAccountPrePreCooldown delta + bsp2 <- (if alreadyInPrePreCooldown then return else addToPrePreCooldowns) bsp1 + return (bsp2, acc1) + EQ -> do + MTL.tell [DelegationConfigureStakeIncreased capital] + return (bsp, acc) + GT -> do + MTL.tell [DelegationConfigureStakeIncreased capital] + let delta = capital - oldCapital + bsp1 <- + onActiveBakers bsp $ + fmap (totalActiveCapital %~ addActiveCapital delta) + . modifyPoolCapitalUnsafe target (+ delta) + maybeCooldownsBefore <- accountCooldowns acc + acc1 <- + setAccountStake capital acc + >>= reactivateCooldownAmount delta + maybeCooldownsAfter <- accountCooldowns acc1 + let removals = cooldownRemovals maybeCooldownsBefore maybeCooldownsAfter + newCooldowns <- applyCooldownRemovalsGlobally ai removals (bspAccountsInCooldown bsp1) + return (bsp1{bspAccountsInCooldown = newCooldowns}, acc1) + onActiveBakers bsp f = do + newPABRef <- refMake =<< f =<< refLoad (bspBirkParameters bsp ^. birkActiveBakers) + return bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newPABRef} + addToPrePreCooldowns :: + (MonadBlobStore m', PVSupportsFlexibleCooldown pv) => + BlockStatePointers pv -> + m' (BlockStatePointers pv) + addToPrePreCooldowns bsp = do + -- Add the account to the pre-pre-cooldowns list. + newAccountsInCooldown <- + (accountsInCooldown . prePreCooldown) + (consAccountList ai) + (bspAccountsInCooldown bsp) + return bsp{bspAccountsInCooldown = newAccountsInCooldown} + +-- | Whether a (pre-)(pre-)cooldown was removed on an account. Used by 'applyCooldownRemovalsGlobally' +-- to then also remove the account from the global list of accounts in cooldown. +data CooldownRemovals = CooldownRemovals + { -- | Whether the pre-pre cooldown was removed. + crPrePreCooldown :: !Bool, + -- | Whether the pre cooldown was removed. + crPreCooldown :: !Bool, + -- | If all cooldowns were removed, this is the previous timestamp of the earliest cooldown. + crCooldown :: !(Maybe Timestamp) + } + +-- | Determine if a change in cooldowns requires global updates to the indexes. +-- The change should arise from (possibly) reactivating stake from cooldown. +-- The first input is old 'Cooldowns' on the account, and the second input is the new 'Cooldowns' on +-- the account after possibly reactivating stake. +cooldownRemovals :: + Maybe CooldownQueue.Cooldowns -> Maybe CooldownQueue.Cooldowns -> CooldownRemovals +cooldownRemovals Nothing _ = CooldownRemovals False False Nothing +cooldownRemovals (Just cd1) Nothing = + CooldownRemovals + { crPrePreCooldown = isPresent (CooldownQueue.prePreCooldown cd1), + crPreCooldown = isPresent (CooldownQueue.preCooldown cd1), + crCooldown = fst <$> Map.lookupMin (CooldownQueue.inCooldown cd1) + } +cooldownRemovals (Just cd1) (Just cd2) = + CooldownRemovals + { crPrePreCooldown = isPresent (CooldownQueue.prePreCooldown cd1) && isAbsent (CooldownQueue.prePreCooldown cd2), + crPreCooldown = isPresent (CooldownQueue.preCooldown cd1) && isAbsent (CooldownQueue.preCooldown cd2), + crCooldown = do + guard (Map.null (CooldownQueue.inCooldown cd2)) + fst <$> Map.lookupMin (CooldownQueue.inCooldown cd1) + } + +-- | Apply cooldown removals for an account to the global indexes. +applyCooldownRemovalsGlobally :: + (MonadBlobStore m, PVSupportsFlexibleCooldown pv) => + AccountIndex -> + CooldownRemovals -> + AccountsInCooldownForPV pv -> + m (AccountsInCooldownForPV pv) +applyCooldownRemovalsGlobally ai CooldownRemovals{..} = + doIf crPrePreCooldown ((accountsInCooldown . prePreCooldown) (removeAccountFromAccountList ai)) + >=> doIf crPreCooldown ((accountsInCooldown . preCooldown) (removeAccountFromAccountList ai)) + >=> case crCooldown of + Just ts -> (accountsInCooldown . cooldown) (removeAccountFromReleaseSchedule ts ai) + Nothing -> return + where + doIf True f = f + doIf False _ = return doUpdateBakerKeys :: (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0) => @@ -2038,7 +2607,7 @@ doUpdateBakerStake pbs ai newStake = do storePBS pbs bsp{bspAccounts = newAccounts} case compare newStake sdStakedCapital of LT -> - if newStake < bakerStakeThreshold + if newStake < max 1 bakerStakeThreshold then return (BSUStakeUnderThreshold, pbs) else (BSUStakeReduced (BakerId ai) (curEpoch + cooldownEpochs),) @@ -2235,8 +2804,8 @@ doMint pbs mint = do bspBank bsp & unhashed %~ (Rewards.totalGTU +~ mintTotal mint) - . (Rewards.bakingRewardAccount +~ mintBakingReward mint) - . (Rewards.finalizationRewardAccount +~ mintFinalizationReward mint) + . (Rewards.bakingRewardAccount +~ mintBakingReward mint) + . (Rewards.finalizationRewardAccount +~ mintFinalizationReward mint) let updAcc = addAccountAmount $ mintDevelopmentCharge mint foundationAccount <- (^. cpFoundationAccount) <$> lookupCurrentParameters (bspUpdates bsp) newAccounts <- Accounts.updateAccountsAtIndex' updAcc foundationAccount (bspAccounts bsp) @@ -3696,15 +4265,15 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoGetCurrentEpochFullBakersEx = doGetCurrentEpochFullBakersEx bsoGetCurrentCapitalDistribution = doGetCurrentCapitalDistribution bsoAddBaker = doAddBaker - bsoConfigureBaker = case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of - SFalse -> case delegationChainParameters @pv of - DelegationChainParameters -> doConfigureBaker - STrue -> undefined -- FIXME: Flexible cooldown unimplemented + bsoAddValidator = case delegationChainParameters @pv of + DelegationChainParameters -> \bs ai a -> MTL.runExceptT (newAddValidator bs ai a) + bsoUpdateValidator = case delegationChainParameters @pv of + DelegationChainParameters -> \bs ts ai u -> MTL.runExceptT (newUpdateValidator bs ts ai u) bsoConstrainBakerCommission = doConstrainBakerCommission - bsoConfigureDelegation = case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of - SFalse -> case delegationChainParameters @pv of - DelegationChainParameters -> doConfigureDelegation - STrue -> undefined -- FIXME: Flexible cooldown unimplemented + bsoAddDelegator = case delegationChainParameters @pv of + DelegationChainParameters -> \bs ai a -> MTL.runExceptT (newAddDelegator bs ai a) + bsoUpdateDelegator = case delegationChainParameters @pv of + DelegationChainParameters -> \bs ts ai u -> MTL.runExceptT (newUpdateDelegator bs ts ai u) bsoUpdateBakerKeys = doUpdateBakerKeys bsoUpdateBakerStake = doUpdateBakerStake bsoUpdateBakerRestakeEarnings = doUpdateBakerRestakeEarnings @@ -3752,6 +4321,9 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoGetBankStatus = doGetBankStatus bsoSetRewardAccounts = doSetRewardAccounts bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective + type StateSnapshot (PersistentBlockStateMonad pv r m) = BlockStatePointers pv + bsoSnapshotState = loadPBS + bsoRollback = storePBS instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where thawBlockState = doThawBlockState @@ -3878,40 +4450,53 @@ migrateBlockPointers migration BlockStatePointers{..} = do StateMigrationParametersP5ToP6{} -> RSMNewToNew StateMigrationParametersP6ToP7{} -> RSMNewToNew StateMigrationParametersP7ToP8{} -> RSMNewToNew + logEvent GlobalState LLTrace "Migrating release schedule" newReleaseSchedule <- migrateReleaseSchedule rsMigration bspReleaseSchedule pab <- lift . refLoad $ bspBirkParameters ^. birkActiveBakers -- When we migrate the accounts, we accumulate state initMigrationState :: MigrationState.AccountMigrationState oldpv pv <- MigrationState.makeInitialAccountMigrationState bspAccounts pab + logEvent GlobalState LLTrace "Migrating accounts" (newAccounts, migrationState) <- MigrationState.runAccountMigrationStateTT (Accounts.migrateAccounts migration bspAccounts) initMigrationState + logEvent GlobalState LLTrace "Migrating accounts in cooldown" newAccountsInCooldown <- migrateAccountsInCooldownForPV (MigrationState._migrationPrePreCooldown migrationState) bspAccountsInCooldown + logEvent GlobalState LLTrace "Migrating modules" newModules <- migrateHashedBufferedRef (Modules.migrateModules migration) bspModules modules <- refLoad newModules + logEvent GlobalState LLTrace "Migrating contract instances" newInstances <- Instances.migrateInstances modules bspInstances let newBank = bspBank + logEvent GlobalState LLTrace "Migrating identity providers" newIdentityProviders <- migrateHashedBufferedRefKeepHash bspIdentityProviders + logEvent GlobalState LLTrace "Migrating anonymity revokers" newAnonymityRevokers <- migrateHashedBufferedRefKeepHash bspAnonymityRevokers let oldEpoch = bspBirkParameters ^. birkSeedState . epoch + logEvent GlobalState LLTrace "Migrating Birk parameters" newBirkParameters <- migratePersistentBirkParameters migration newAccounts (MigrationState._persistentActiveBakers migrationState) bspBirkParameters + logEvent GlobalState LLTrace "Migrating cryptographic parameters" newCryptographicParameters <- migrateHashedBufferedRefKeepHash bspCryptographicParameters + logEvent GlobalState LLTrace "Migrating chain parameters and updates updates" newUpdates <- migrateReference (migrateUpdates migration) bspUpdates + logEvent GlobalState LLTrace "Migrating current epoch bakers" curBakers <- extractBakerStakes =<< refLoad (_birkCurrentEpochBakers newBirkParameters) + logEvent GlobalState LLTrace "Migrating next epoch bakers" nextBakers <- extractBakerStakes =<< refLoad (_birkNextEpochBakers newBirkParameters) -- clear transaction outcomes. let newTransactionOutcomes = emptyTransactionOutcomes (Proxy @pv) chainParams <- refLoad . currentParameters =<< refLoad newUpdates let timeParams = _cpTimeParameters . unStoreSerialized $ chainParams + logEvent GlobalState LLTrace "Migrating reward details" newRewardDetails <- migrateBlockRewardDetails migration curBakers nextBakers timeParams oldEpoch bspRewardDetails diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs index 53520bcab..61902188f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs @@ -17,6 +17,7 @@ module Concordium.GlobalState.Persistent.PoolRewards ( lookupBakerCapitalAndRewardDetails, migratePoolRewardsP1, migratePoolRewards, + migratePoolRewardsP6, ) where import Control.Exception (assert) @@ -67,7 +68,8 @@ data PoolRewards (bhv :: BlockHashVersion) = PoolRewards -- | Migrate pool rewards from @m@ to the new backing store @t m@. -- This takes the new next payday epoch as a parameter, since this should always be updated on --- a protocol update. The hashes for the +-- a protocol update. The hashes for the capital distributions are recomputed, as they schema +-- may change between versions. migratePoolRewards :: (SupportMigration m t, IsBlockHashVersion bhv1) => Epoch -> @@ -77,6 +79,7 @@ migratePoolRewards newNextPayday PoolRewards{..} = do nextCapital' <- migrateHashedBufferedRef return nextCapital currentCapital' <- migrateHashedBufferedRef return currentCapital bakerPoolRewardDetails' <- LFMBT.migrateLFMBTree (migrateReference return) bakerPoolRewardDetails + -- the remaining fields are flat, so migration is copying return PoolRewards { nextCapital = nextCapital', @@ -86,7 +89,22 @@ migratePoolRewards newNextPayday PoolRewards{..} = do .. } --- the remaining fields are flat, so migration is copying +-- | Migrate pool rewards from @m@ to the new backing store @t m@, for use with consensus version 1. +-- This takes the pre-migration epoch number and reward period length as parameters, and sets the +-- next payday epoch to be the the number of epochs that were remaining until the next payday +-- at the time of the migration, or the length of the reward period if that is smaller. +migratePoolRewardsP6 :: + (SupportMigration m t, IsBlockHashVersion bhv1) => + -- | The epoch number before the migration. + Epoch -> + -- | The length of the reward period. + RewardPeriodLength -> + PoolRewards bhv0 -> + t m (PoolRewards bhv1) +migratePoolRewardsP6 oldEpoch rpLength pr = migratePoolRewards newNextPayday pr + where + oldPaydayEpoch = nextPaydayEpoch pr + newNextPayday = max 1 (min (rewardPeriodEpochs rpLength) (oldPaydayEpoch - oldEpoch)) -- | Migrate pool rewards from the format before delegation to the P4 format. migratePoolRewardsP1 :: diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 73c014461..753673091 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -111,7 +111,8 @@ newtype SkovV1T pv m a = SkovV1T MonadLogger, TimeMonad, MonadReader (SkovV1Context pv m), - MonadThrow + MonadThrow, + MonadCatch ) deriving (BlockStateTypes, ContractStateOperations, ModuleQuery) @@ -299,17 +300,17 @@ instance (Monad m) => MonadConsensusEvent (SkovV1T pv m) where handler <- view onFinalizeHandler handler fe bp -instance (MonadIO m, MonadLogger m) => TimerMonad (SkovV1T pv m) where +instance (MonadIO m, MonadLogger m, MonadCatch m) => TimerMonad (SkovV1T pv m) where type Timer (SkovV1T pv m) = ThreadTimer onTimeout timeout a = do ctx <- ask liftIO $ makeThreadTimer timeout $ do - let handler (SomeException e) = - _skovV1TUnliftIO ctx $ - logEvent Konsensus LLError $ - "Error in timer thread: " ++ show e - void (_skovV1TUnliftIO ctx a) `catchAll` handler + let handler ex@(SomeException e) = do + logEvent Konsensus LLError $ + "Error in timer thread: " ++ displayException e + throwM ex + _skovV1TUnliftIO ctx (void a `catch` handler) cancelTimer = liftIO . cancelThreadTimer instance diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 577eb6f7a..24095714e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -247,8 +247,8 @@ loadSkovData _genesisBlockHeight _runtimeParameters didRollback = do && not consensusIsShutdown then case mLatestFinEntry of Nothing -> - throwM . TreeStateInvariantViolation $ - "Missing finalization entry for last finalized block" + -- In this case, by the above check, the last finalized block is the genesis block. + return (blockEpoch lastFinBlock, Absent) Just finEntry -> return (blockEpoch lastFinBlock + 1, Present finEntry) else return (blockEpoch lastFinBlock, Absent) chainParams <- getChainParameters $ bpState lastFinBlock diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index 3a3a2bf32..3ee5f15b0 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -23,9 +23,9 @@ module Concordium.MultiVersion where import Control.Concurrent -import Control.Exception +import Control.Exception hiding (handle) import Control.Monad -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM)) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM), handle) import Control.Monad.Reader import qualified Control.Monad.State.Strict as State import Data.ByteString (ByteString) @@ -34,6 +34,7 @@ import Data.IORef import Data.Serialize import qualified Data.Text as Text import Data.Time +import Data.Typeable import qualified Data.Vector as Vec import System.FilePath @@ -500,6 +501,26 @@ data CatchUpStatusBufferState | -- | We should not send any more catch-up status messages. BufferShutdown +-- | A representation of whether the global write lock has been poisoned due to an exception in +-- a thread that held the lock. +data GlobalStateStatus + = -- | The global state is in a consistent state. + GSOk + | -- | A thread has thrown an exception while processing the global state, indicating an + -- unrecoverable error. + GSError + deriving (Eq) + +-- | An exception indicating that the global state lock was poisoned by an error in another thread. +-- This indicates that some invariants of the global state may have been violated, and is not +-- recoverable. +data GlobalLockPoisonError = GlobalLockPoisonError + deriving (Eq, Show, Typeable) + +instance Exception GlobalLockPoisonError where + displayException _ = + "The global state lock was poisoned by an unrecoverable error in another thread." + -- | The context for managing multi-version consensus. data MultiVersionRunner finconf = MultiVersionRunner { -- | Base configuration. @@ -515,7 +536,7 @@ data MultiVersionRunner finconf = MultiVersionRunner -- the write lock is held. mvVersions :: !(IORef (Vec.Vector (EVersionedConfiguration finconf))), -- | Global write lock. - mvWriteLock :: !(MVar ()), + mvWriteLock :: !(MVar GlobalStateStatus), -- | Flag to stop importing blocks. When importing blocks from a file is in progress, -- setting this flag to True will cause the import to stop. mvShouldStopImportingBlocks :: !(IORef Bool), @@ -546,6 +567,25 @@ instance MonadLogger (MVR finconf) where logEvent src lvl msg = MVR $ \mvr -> mvLog mvr src lvl msg {-# INLINE logEvent #-} +-- | Catch and log exceptions in the 'MVR' monad. +-- Returns a specified value in the event of an exception. +handleMVRExceptionsWith :: + -- | Value to return in the event of an exception. + a -> + -- | Action to run + MVR finconf a -> + MVR finconf a +handleMVRExceptionsWith failRes = handle handler + where + handler (e :: SomeException) = do + logEvent Runner LLError $ "Unrecoverable exception: " <> displayException e + return failRes + +-- | Catch and log exceptions in the 'MVR' monad. +-- Returns 'Skov.ResultConsensusFailure' in the event of an exception. +handleMVRExceptions :: MVR finconf Skov.UpdateResult -> MVR finconf Skov.UpdateResult +handleMVRExceptions = handleMVRExceptionsWith Skov.ResultConsensusFailure + -- | Perform an action while holding the global state write lock. -- If the action throws an exception, this ensures that the lock is -- released. @@ -561,14 +601,23 @@ withWriteLockIO :: MultiVersionRunner finconf -> IO a -> IO a withWriteLockIO MultiVersionRunner{..} a = bracketOnError (takeMVar mvWriteLock) - ( \() -> - tryPutMVar mvWriteLock () - >> mvLog Runner LLWarning "Released global state lock following error." + ( \_ -> do + poisoned <- tryPutMVar mvWriteLock GSError + when poisoned $ + mvLog + Runner + LLWarning + "An error occurred while holding the global state lock.\ + \ This will be propagated to other threads." ) - $ \_ -> do - res <- a - putMVar mvWriteLock () - return res + $ \case + GSOk -> do + res <- a + putMVar mvWriteLock GSOk + return res + GSError -> do + putMVar mvWriteLock GSError + throwIO GlobalLockPoisonError -- | Perform an action while holding the global state write lock. Optionally, when the action -- completes, a thread is forked to perform a follow-up action before releasing the lock. @@ -585,17 +634,26 @@ withWriteLockMaybeFork action followup = MVR $ \mvr -> withWriteLockMaybeForkIO :: MultiVersionRunner finconf -> IO (a, Maybe b) -> (b -> IO ()) -> IO a {-# INLINE withWriteLockMaybeForkIO #-} withWriteLockMaybeForkIO MultiVersionRunner{..} action followup = mask $ \unmask -> do - () <- takeMVar mvWriteLock - (res, mContinue) <- unmask action `onException` tryPutMVar mvWriteLock () + gsStatus <- takeMVar mvWriteLock + when (gsStatus == GSError) $ do + putMVar mvWriteLock GSError + throwIO GlobalLockPoisonError + (res, mContinue) <- unmask action `onException` tryPutMVar mvWriteLock GSError case mContinue of Just continueArg -> do - let release = putMVar mvWriteLock () + let release (Left exception) = do + mvLog Runner LLError $ + "An unrecovarable error occurred in a worker thread\ + \ while holding the global state lock: " + ++ show exception + putMVar mvWriteLock GSError + release (Right _) = putMVar mvWriteLock GSOk -- forkIO is guaranteed to be uninterruptible, so we can be sure that an async exception -- won't prevent the lock being released. Also note that the masking state of the thread -- is inherited, so we unmask when running the follow-up. - void $ forkIO (unmask (try @SomeException (followup continueArg)) >> release) + void $ forkIO (unmask (try @SomeException (followup continueArg)) >>= release) Nothing -> do - putMVar mvWriteLock () + putMVar mvWriteLock GSOk return res -- | Lift a 'LogIO' action into the 'MVR' monad. @@ -1137,7 +1195,7 @@ makeMultiVersionRunner mvTransactionPurgingThread <- newEmptyMVar let mvr = MultiVersionRunner{..} runMVR (startupSkov genesis) mvr - putMVar mvWriteLock () + putMVar mvWriteLock GSOk startTransactionPurgingThread mvr return mvr @@ -1256,7 +1314,7 @@ startupSkov genesis = do -- continue to the next iteration. If the state for the next -- configuration is missing, 'activateThis' is called which will -- activate the configuration and trigger the protocol update. - loadLoop nextSPV activateThis (genIndex + 1) (fromIntegral lastFinalizedHeight + 1) + loadLoop nextSPV activateThis (genIndex + 1) (lastFinalizedHeight + 1) Nothing -> activateLast ConsensusV1 -> do let !handlers = skovV1Handlers genIndex genHeight @@ -1319,7 +1377,7 @@ startupSkov genesis = do nextSPV activateThis (genIndex + 1) - (fromIntegral esLastFinalizedHeight + 1) + (localToAbsoluteBlockHeight genHeight esLastFinalizedHeight + 1) _ -> do -- This is still the current configuration (i.e. no protocol update -- has occurred, or the protocol update is not supported), so @@ -1467,12 +1525,14 @@ shutdownMultiVersionRunner MultiVersionRunner{..} = mask_ $ do -- Kill the transaction purging thread, if any. tryTakeMVar mvTransactionPurgingThread >>= mapM_ killThread -- Acquire the write lock. This prevents further updates, as they will block. - takeMVar mvWriteLock - versions <- readIORef mvVersions - -- Shut down the consensus databases. - runLoggerT (forM_ versions evcShutdown) mvLog - -- Shut down the global account map. - LMDBAccountMap.closeDatabase (globalAccountMap (mvcStateConfig mvConfiguration)) + takeMVar mvWriteLock >>= \case + GSOk -> do + versions <- readIORef mvVersions + -- Shut down the consensus databases. + runLoggerT (forM_ versions evcShutdown) mvLog + -- Shut down the global account map. + LMDBAccountMap.closeDatabase (globalAccountMap (mvcStateConfig mvConfiguration)) + GSError -> throwIO GlobalLockPoisonError -- | Lift a version-0 consensus skov action to the 'MVR' monad, running it on a -- particular 'VersionedConfigurationV0'. Note that this does not @@ -1678,58 +1738,67 @@ receiveBlock :: GenesisIndex -> ByteString -> MVR finconf (Skov.UpdateResult, Maybe ExecuteBlock) -receiveBlock gi blockBS = withLatestExpectedVersion gi $ \case - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> do - MVR $ \mvr -> do - now <- currentTime - case deserializeExactVersionedPendingBlock (protocolVersion @pv) blockBS now of - Left err -> do - mvLog mvr Runner LLDebug err - return (Skov.ResultSerializationFail, Nothing) - Right block -> do - (updateResult, mVerifiedPendingBlock) <- runMVR (runSkovV0Transaction vc (Skov.receiveBlock block)) mvr - case mVerifiedPendingBlock of - Nothing -> return (updateResult, Nothing) - Just verifiedPendingBlock -> do - let exec = do - runSkovV0Transaction vc (Skov.executeBlock verifiedPendingBlock) - let cont = ExecuteBlock $ runMVR exec mvr - return (updateResult, Just cont) - (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> do - MVR $ \mvr -> do - now <- currentTime - case SkovV1.deserializeExactVersionedPendingBlock @pv blockBS now of - Left err -> do - mvLog mvr Runner LLDebug err - return (Skov.ResultSerializationFail, Nothing) - Right block -> do - blockResult <- runMVR (runSkovV1Transaction vc (SkovV1.uponReceivingBlock block)) mvr - case blockResult of - SkovV1.BlockResultSuccess vb -> do - let exec = do - runSkovV1Transaction vc (SkovV1.executeBlock vb) - return Skov.ResultSuccess - let cont = ExecuteBlock $ runMVR exec mvr - return (Skov.ResultSuccess, Just cont) - SkovV1.BlockResultDoubleSign vb -> do - runMVR (runSkovV1Transaction vc (SkovV1.executeBlock vb)) mvr - return (Skov.ResultDoubleSign, Nothing) - SkovV1.BlockResultInvalid -> return (Skov.ResultInvalid, Nothing) - SkovV1.BlockResultStale -> return (Skov.ResultStale, Nothing) - SkovV1.BlockResultPending -> return (Skov.ResultPendingBlock, Nothing) - SkovV1.BlockResultEarly -> return (Skov.ResultEarlyBlock, Nothing) - SkovV1.BlockResultDuplicate -> return (Skov.ResultDuplicate, Nothing) - SkovV1.BlockResultConsensusShutdown -> return (Skov.ResultConsensusShutDown, Nothing) +receiveBlock gi blockBS = handleMVRExceptionsWith (Skov.ResultConsensusFailure, Nothing) $ + withLatestExpectedVersion gi $ \case + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> do + MVR $ \mvr -> do + now <- currentTime + case deserializeExactVersionedPendingBlock (protocolVersion @pv) blockBS now of + Left err -> do + mvLog mvr Runner LLDebug err + return (Skov.ResultSerializationFail, Nothing) + Right block -> do + (updateResult, mVerifiedPendingBlock) <- + runMVR + (runSkovV0Transaction vc (Skov.receiveBlock block)) + mvr + case mVerifiedPendingBlock of + Nothing -> return (updateResult, Nothing) + Just verifiedPendingBlock -> do + let exec = do + runSkovV0Transaction vc $ + Skov.executeBlock verifiedPendingBlock + let cont = ExecuteBlock $ runMVR exec mvr + return (updateResult, Just cont) + (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> do + MVR $ \mvr -> do + now <- currentTime + case SkovV1.deserializeExactVersionedPendingBlock @pv blockBS now of + Left err -> do + mvLog mvr Runner LLDebug err + return (Skov.ResultSerializationFail, Nothing) + Right block -> do + blockResult <- + runMVR + (runSkovV1Transaction vc (SkovV1.uponReceivingBlock block)) + mvr + case blockResult of + SkovV1.BlockResultSuccess vb -> do + let exec = do + runSkovV1Transaction vc (SkovV1.executeBlock vb) + return Skov.ResultSuccess + let cont = ExecuteBlock $ runMVR exec mvr + return (Skov.ResultSuccess, Just cont) + SkovV1.BlockResultDoubleSign vb -> do + runMVR (runSkovV1Transaction vc (SkovV1.executeBlock vb)) mvr + return (Skov.ResultDoubleSign, Nothing) + SkovV1.BlockResultInvalid -> return (Skov.ResultInvalid, Nothing) + SkovV1.BlockResultStale -> return (Skov.ResultStale, Nothing) + SkovV1.BlockResultPending -> return (Skov.ResultPendingBlock, Nothing) + SkovV1.BlockResultEarly -> return (Skov.ResultEarlyBlock, Nothing) + SkovV1.BlockResultDuplicate -> return (Skov.ResultDuplicate, Nothing) + SkovV1.BlockResultConsensusShutdown -> + return (Skov.ResultConsensusShutDown, Nothing) -- | Invoke the continuation yielded by 'receiveBlock'. -- The continuation performs a transaction which will acquire the write lock -- before trying to add the block to the tree and release the lock again afterwards. executeBlock :: ExecuteBlock -> MVR finconf Skov.UpdateResult -executeBlock = liftIO . runBlock +executeBlock = handleMVRExceptions . liftIO . runBlock -- | Deserialize and receive a finalization message at a given genesis index. receiveFinalizationMessage :: GenesisIndex -> ByteString -> MVR finconf Skov.UpdateResult -receiveFinalizationMessage gi finMsgBS = withLatestExpectedVersion_ gi $ \case +receiveFinalizationMessage gi finMsgBS = handleMVRExceptions $ withLatestExpectedVersion_ gi $ \case (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> case runGet getExactVersionedFPM finMsgBS of Left err -> do @@ -1748,16 +1817,16 @@ receiveFinalizationMessage gi finMsgBS = withLatestExpectedVersion_ gi $ \case Left leftRes -> (leftRes, Nothing) Right cont -> (Skov.ResultSuccess, Just cont) followup = liftSkovV1Update vc - -- We spawn a thread to perform the follow-up so that the P2P layer can immediately - -- relay the message, since the follow-up action can be time consuming (including - -- finalizing blocks and baking a new block). + -- We spawn a thread to perform the follow-up so that the P2P layer can + -- immediately relay the message, since the follow-up action can be time + -- consuming (including finalizing blocks and baking a new block). withWriteLockMaybeFork receive followup -- | Deserialize and receive a finalization entity. -- For consensus version 0 this should be a 'FinalizationRecord'. -- For consensus version 1 this should be a 'FinalizationEntry'. receiveFinalization :: GenesisIndex -> ByteString -> MVR finconf Skov.UpdateResult -receiveFinalization gi finBS = withLatestExpectedVersion_ gi $ \case +receiveFinalization gi finBS = handleMVRExceptions $ withLatestExpectedVersion_ gi $ \case (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> case runGet getExactVersionedFinalizationRecord finBS of Left err -> do @@ -1794,7 +1863,7 @@ receiveCatchUpStatus :: CatchUpConfiguration -> MVR finconf Skov.UpdateResult receiveCatchUpStatus gi catchUpBS cuConfig@CatchUpConfiguration{..} = - case runGet getVersionedCatchUpStatus catchUpBS of + handleMVRExceptions $ case runGet getVersionedCatchUpStatus catchUpBS of Left err -> do logEvent Runner LLDebug $ "Could not deserialize catch-up status message: " ++ err return Skov.ResultSerializationFail @@ -1988,7 +2057,7 @@ getCatchUpRequest = do -- the result of the update. The hash is present unless the transaction could -- not be deserialized. receiveTransaction :: forall finconf. ByteString -> MVR finconf (Maybe TransactionHash, Skov.UpdateResult) -receiveTransaction transactionBS = do +receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.ResultConsensusFailure) $ do now <- utcTimeToTransactionTime <$> currentTime mvr <- ask vvec <- liftIO $ readIORef $ mvVersions mvr @@ -2094,7 +2163,7 @@ receiveExecuteBlock gi blockBS = withLatestExpectedVersion_ gi $ \case -- | Import a block file for out-of-band catch-up. importBlocks :: FilePath -> MVR finconf Skov.UpdateResult -importBlocks importFile = do +importBlocks importFile = handleMVRExceptions $ do vvec <- liftIO . readIORef =<< asks mvVersions -- Import starting from the genesis index of the latest consensus let genIndex = evcIndex (Vec.last vvec) diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs index aad1fc8bd..ff679c785 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs @@ -74,10 +74,8 @@ import Concordium.Types.ProtocolVersion -- | The hash that identifies a update from P6 to P7 protocol. -- This is the hash of the published specification document. --- Currently, this it the dummy value: --- 4a875d7b7457b0f077dddeb384a059635d183e198112421e4be884e4cccec3b1 updateHash :: SHA256.Hash -updateHash = SHA256.hash "P6.ProtocolP7-placeholder-until-spec-hash-is-known" +updateHash = read "e68ea0b16bbadfa5e5da768ed9afe0880bd572e29337fe6fb584f293ed7699d6" -- | Construct the genesis data for a P6.ProtocolP7 update. -- This takes the terminal block of the old chain which is used as the basis for constructing diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs index 0d5d0d3f5..d18f85fdb 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs @@ -18,19 +18,29 @@ import qualified Concordium.GlobalState.Types as GSTypes import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import qualified Concordium.ProtocolUpdate.P6 as P6 +import qualified Concordium.ProtocolUpdate.P7 as P7 -- | Type representing currently supported protocol update types. data Update (pv :: ProtocolVersion) where UpdateP6 :: P6.Update -> Update 'P6 + UpdateP7 :: P7.Update -> Update 'P7 instance Show (Update pv) where show (UpdateP6 u) = "P6." ++ show u + show (UpdateP7 u) = "P7." ++ show u -- | Determine if a 'ProtocolUpdate' corresponds to a supported update type. checkUpdate :: forall pv. (IsProtocolVersion pv) => ProtocolUpdate -> Either String (Update pv) checkUpdate = case protocolVersion @pv of + -- These ones are only supported in V0. + SP1 -> const $ Left "Update to P1 unsupported in V1." + SP2 -> const $ Left "Update to P2 unsupported in V1." + SP3 -> const $ Left "Update to P3 unsupported in V1." + SP4 -> const $ Left "Update to P4 unsupported in V1." + SP5 -> const $ Left "Update to P5 unsupported in V1." + -- These ones are supported in V1. SP6 -> fmap UpdateP6 . P6.checkUpdate - _ -> const $ Left "Unsupported update." + SP7 -> fmap UpdateP7 . P7.checkUpdate -- | Construct the genesis data for a P1 update. updateRegenesis :: @@ -44,6 +54,7 @@ updateRegenesis :: BlockPointer (MPV m) -> m (PVInit m) updateRegenesis (UpdateP6 u) = P6.updateRegenesis u +updateRegenesis (UpdateP7 u) = P7.updateRegenesis u -- | Determine the next protocol version for the given update. Although the same -- information can be retrieved from 'updateRegenesis', this is more efficient @@ -52,3 +63,4 @@ updateNextProtocolVersion :: Update pv -> SomeProtocolVersion updateNextProtocolVersion (UpdateP6 u) = P6.updateNextProtocolVersion u +updateNextProtocolVersion (UpdateP7 u) = P7.updateNextProtocolVersion u diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 52b7a5fff..937cb55b6 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -2021,29 +2021,33 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK else return (TxReject InvalidProof, energyCost, usedEnergy) -- | Argument to configure baker 'withDeposit' continuation. -data ConfigureBakerCont - = ConfigureAddBakerCont - { cbcCapital :: !Amount, - cbcRestakeEarnings :: !Bool, - cbcOpenForDelegation :: !OpenStatus, - cbcKeysWithProofs :: !BakerKeysWithProofs, - cbcMetadataURL :: !UrlText, - cbcTransactionFeeCommission :: !AmountFraction, - cbcBakingRewardCommission :: !AmountFraction, - cbcFinalizationRewardCommission :: !AmountFraction +data ConfigureBakerCont (av :: AccountVersion) + = CBCAdd + { -- | When flexible cooldown is supported, we can add a baker when there already is a + -- delegator on the account, but we have to remove the delegator first. This flag indicates + -- if there is a delegator to remove. + cbcRemoveDelegator :: !(Conditionally (SupportsFlexibleCooldown av) Bool), + -- | The parameters defining the baker to add. + cbcValidatorAdd :: !BI.ValidatorAdd } - | ConfigureUpdateBakerCont - --- | Argument to configure delegation 'withDeposit' continuation. -data ConfigureDelegationCont - = ConfigureAddDelegationCont - { cdcCapital :: !Amount, - cdcRestakeEarnings :: !Bool, - cdcDelegationTarget :: !DelegationTarget + | CBCUpdate + { -- | The parameters defining the update to the baker. + cbcValidatorUpdate :: !BI.ValidatorUpdate } - | ConfigureUpdateDelegationCont +-- | Check that the ownership proofs for keys used for a configure baker transaction are valid. +checkConfigureBakerKeys :: AccountAddress -> BakerKeysWithProofs -> Bool +checkConfigureBakerKeys senderAddress BakerKeysWithProofs{..} = + electionP && signP && aggregationP + where + challenge = configureBakerKeyChallenge senderAddress bkwpElectionVerifyKey bkwpSignatureVerifyKey bkwpAggregationVerifyKey + electionP = checkElectionKeyProof challenge bkwpElectionVerifyKey bkwpProofElection + signP = checkSignatureVerifyKeyProof challenge bkwpSignatureVerifyKey bkwpProofSig + aggregationP = Bls.checkProofOfKnowledgeSK challenge bkwpProofAggregation bkwpAggregationVerifyKey + +-- | Handler for a configure baker transaction. handleConfigureBaker :: + forall m. ( PVSupportsDelegation (MPV m), SchedulerMonad m ) => @@ -2078,176 +2082,176 @@ handleConfigureBaker withDeposit wtc tickGetArgAndBalance chargeAndExecute where senderAccount = wtc ^. wtcSenderAccount + senderAccountIndex = fst senderAccount + bid = BakerId senderAccountIndex senderAddress = wtc ^. wtcSenderAddress - configureAddBakerArg = - case ( cbCapital, - cbRestakeEarnings, - cbOpenForDelegation, - cbKeysWithProofs, - cbMetadataURL, - cbTransactionFeeCommission, - cbBakingRewardCommission, - cbFinalizationRewardCommission - ) of - ( Just cbcCapital, - Just cbcRestakeEarnings, - Just cbcOpenForDelegation, - Just cbcKeysWithProofs, - Just cbcMetadataURL, - Just cbcTransactionFeeCommission, - Just cbcBakingRewardCommission, - Just cbcFinalizationRewardCommission - ) -> - return ConfigureAddBakerCont{..} - _ -> - rejectTransaction MissingBakerAddParameters - configureUpdateBakerArg = - return ConfigureUpdateBakerCont - areKeysOK BakerKeysWithProofs{..} = - let challenge = configureBakerKeyChallenge senderAddress bkwpElectionVerifyKey bkwpSignatureVerifyKey bkwpAggregationVerifyKey - electionP = checkElectionKeyProof challenge bkwpElectionVerifyKey bkwpProofElection - signP = checkSignatureVerifyKeyProof challenge bkwpSignatureVerifyKey bkwpProofSig - aggregationP = Bls.checkProofOfKnowledgeSK challenge bkwpProofAggregation bkwpAggregationVerifyKey - in electionP && signP && aggregationP + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor (MPV m))) + mCBCAdd :: + Conditionally (SupportsFlexibleCooldown (AccountVersionFor (MPV m))) Bool -> + Amount -> + Bool -> + Maybe (ConfigureBakerCont (AccountVersionFor (MPV m))) + mCBCAdd removeDelegator vaCapital vaRestakeEarnings = do + vaKeys <- BI.bakerKeysWithoutProofs <$> cbKeysWithProofs + _transactionCommission <- cbTransactionFeeCommission + _bakingCommission <- cbBakingRewardCommission + _finalizationCommission <- cbFinalizationRewardCommission + let vaCommissionRates = CommissionRates{..} + vaOpenForDelegation <- cbOpenForDelegation + vaMetadataURL <- cbMetadataURL + return + CBCAdd + { cbcRemoveDelegator = removeDelegator, + cbcValidatorAdd = BI.ValidatorAdd{..} + } + makeArg = do + accountStake <- getAccountStake (snd senderAccount) + case accountStake of + AccountStakeNone -> do + let removeDelegator = conditionally flexibleCooldown False + case join $ mCBCAdd removeDelegator <$> cbCapital <*> cbRestakeEarnings of + Just va -> return va + Nothing -> rejectTransaction MissingBakerAddParameters + AccountStakeDelegate del -> case flexibleCooldown of + SFalse -> rejectTransaction AlreadyADelegator + STrue -> do + -- Where flexible cooldown is supported, we can transition from a + -- delegator to a validator. If the stake amount or restake earnings + -- flags are not specified, we inherit them from the delegator. + let capital = fromMaybe (_delegationStakedAmount del) cbCapital + let restake = fromMaybe (_delegationStakeEarnings del) cbRestakeEarnings + case mCBCAdd (CTrue True) capital restake of + Just va -> return va + Nothing -> rejectTransaction MissingBakerAddParameters + AccountStakeBaker _ -> do + return + CBCUpdate + { cbcValidatorUpdate = + BI.ValidatorUpdate + { vuKeys = BI.bakerKeysWithoutProofs <$> cbKeysWithProofs, + vuCapital = cbCapital, + vuRestakeEarnings = cbRestakeEarnings, + vuMetadataURL = cbMetadataURL, + vuTransactionFeeCommission = cbTransactionFeeCommission, + vuBakingRewardCommission = cbBakingRewardCommission, + vuFinalizationRewardCommission = cbFinalizationRewardCommission, + vuOpenForDelegation = cbOpenForDelegation + } + } tickGetArgAndBalance = do -- Charge the energy cost before checking the validity of the parameters. if isJust cbKeysWithProofs then tickEnergy Cost.configureBakerCostWithKeys else tickEnergy Cost.configureBakerCostWithoutKeys - accountStake <- getAccountStake (snd senderAccount) - arg <- case accountStake of - AccountStakeNone -> configureAddBakerArg - AccountStakeDelegate _ -> rejectTransaction AlreadyADelegator - AccountStakeBaker _ -> - configureUpdateBakerArg + arg <- makeArg (arg,) <$> getCurrentAccountTotalAmount senderAccount chargeAndExecute ls argAndBalance = do (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost - executeConfigure energyCost usedEnergy argAndBalance - executeConfigure energyCost usedEnergy (ConfigureAddBakerCont{..}, accountBalance) = do - if accountBalance < cbcCapital - then -- The balance is insufficient. - return (TxReject InsufficientBalanceForBakerStake, energyCost, usedEnergy) - else - if areKeysOK cbcKeysWithProofs - then do - let bca = - BI.BakerConfigureAdd - { bcaKeys = - BI.BakerKeyUpdate - { bkuSignKey = bkwpSignatureVerifyKey cbcKeysWithProofs, - bkuAggregationKey = bkwpAggregationVerifyKey cbcKeysWithProofs, - bkuElectionKey = bkwpElectionVerifyKey cbcKeysWithProofs - }, - bcaCapital = cbcCapital, - bcaRestakeEarnings = cbcRestakeEarnings, - bcaOpenForDelegation = cbcOpenForDelegation, - bcaMetadataURL = cbcMetadataURL, - bcaTransactionFeeCommission = cbcTransactionFeeCommission, - bcaBakingRewardCommission = cbcBakingRewardCommission, - bcaFinalizationRewardCommission = cbcFinalizationRewardCommission - } - res <- configureBaker (fst senderAccount) bca - kResult energyCost usedEnergy bca res - else return (TxReject InvalidProof, energyCost, usedEnergy) - executeConfigure energyCost usedEnergy (ConfigureUpdateBakerCont, accountBalance) = do - if maybe False (accountBalance <) cbCapital - then return (TxReject InsufficientBalanceForBakerStake, energyCost, usedEnergy) - else - if maybe True areKeysOK cbKeysWithProofs - then do - -- The proof validates that the baker owns all the private keys, - -- thus we can try to create the baker. - let bku = - cbKeysWithProofs <&> \BakerKeysWithProofs{..} -> - BI.BakerKeyUpdate - { bkuSignKey = bkwpSignatureVerifyKey, - bkuAggregationKey = bkwpAggregationVerifyKey, - bkuElectionKey = bkwpElectionVerifyKey - } - cm <- getChainMetadata - let bcu = - BI.BakerConfigureUpdate - { bcuSlotTimestamp = slotTime cm, - bcuKeys = bku, - bcuCapital = cbCapital, - bcuRestakeEarnings = cbRestakeEarnings, - bcuOpenForDelegation = cbOpenForDelegation, - bcuMetadataURL = cbMetadataURL, - bcuTransactionFeeCommission = cbTransactionFeeCommission, - bcuBakingRewardCommission = cbBakingRewardCommission, - bcuFinalizationRewardCommission = cbFinalizationRewardCommission - } - res <- configureBaker (fst senderAccount) bcu - kResult energyCost usedEnergy bcu res - else return (TxReject InvalidProof, energyCost, usedEnergy) - kResult energyCost usedEnergy BI.BakerConfigureUpdate{} (BI.BCSuccess changes bid) = do - let events = - changes <&> \case - BI.BakerConfigureStakeIncreased newStake -> - BakerStakeIncreased bid senderAddress newStake - BI.BakerConfigureStakeReduced newStake - | newStake == 0 -> BakerRemoved bid senderAddress - | otherwise -> BakerStakeDecreased bid senderAddress newStake - BI.BakerConfigureRestakeEarnings newRestakeEarnings -> - BakerSetRestakeEarnings bid senderAddress newRestakeEarnings - BI.BakerConfigureOpenForDelegation newOpenStatus -> - BakerSetOpenStatus bid senderAddress newOpenStatus - BI.BakerConfigureUpdateKeys BI.BakerKeyUpdate{..} -> - BakerKeysUpdated - { ebkuBakerId = bid, - ebkuAccount = senderAddress, - ebkuSignKey = bkuSignKey, - ebkuElectionKey = bkuElectionKey, - ebkuAggregationKey = bkuAggregationKey - } - BI.BakerConfigureMetadataURL newMetadataURL -> - BakerSetMetadataURL bid senderAddress newMetadataURL - BI.BakerConfigureTransactionFeeCommission transactionFeeCommission -> - BakerSetTransactionFeeCommission bid senderAddress transactionFeeCommission - BI.BakerConfigureBakingRewardCommission bakingRewardCommission -> - BakerSetBakingRewardCommission bid senderAddress bakingRewardCommission - BI.BakerConfigureFinalizationRewardCommission finalizationRewardCommission -> - BakerSetFinalizationRewardCommission bid senderAddress finalizationRewardCommission - return (TxSuccess events, energyCost, usedEnergy) - kResult energyCost usedEnergy BI.BakerConfigureAdd{..} (BI.BCSuccess _ bid) = do - let events = - [ BakerAdded - { ebaBakerId = bid, - ebaAccount = senderAddress, - ebaSignKey = BI.bkuSignKey bcaKeys, - ebaElectionKey = BI.bkuElectionKey bcaKeys, - ebaAggregationKey = BI.bkuAggregationKey bcaKeys, - ebaStake = bcaCapital, - ebaRestakeEarnings = bcaRestakeEarnings - }, - BakerSetRestakeEarnings bid senderAddress bcaRestakeEarnings, - BakerSetOpenStatus bid senderAddress bcaOpenForDelegation, - BakerSetMetadataURL bid senderAddress bcaMetadataURL, - BakerSetTransactionFeeCommission bid senderAddress bcaTransactionFeeCommission, - BakerSetBakingRewardCommission bid senderAddress bcaBakingRewardCommission, - BakerSetFinalizationRewardCommission bid senderAddress bcaFinalizationRewardCommission - ] - return (TxSuccess events, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCInvalidAccount = - return (TxReject (InvalidAccountReference senderAddress), energyCost, usedEnergy) - kResult energyCost usedEnergy _ (BI.BCDuplicateAggregationKey key) = - return (TxReject (DuplicateAggregationKey key), energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCStakeUnderThreshold = - return (TxReject StakeUnderMinimumThresholdForBaking, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCTransactionFeeCommissionNotInRange = - return (TxReject TransactionFeeCommissionNotInRange, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCBakingRewardCommissionNotInRange = - return (TxReject BakingRewardCommissionNotInRange, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCFinalizationRewardCommissionNotInRange = - return (TxReject FinalizationRewardCommissionNotInRange, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCChangePending = - return (TxReject BakerInCooldown, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.BCInvalidBaker = - return (TxReject (NotABaker senderAddress), energyCost, usedEnergy) + result <- executeConfigure argAndBalance + return (result, energyCost, usedEnergy) + -- Check the proofs are valid, if we are updating the keys. + -- (If there is no key update, then this is trivially 'True'.) + proofsValid = maybe True (checkConfigureBakerKeys senderAddress) cbKeysWithProofs + executeConfigure (CBCAdd{..}, accountBalance) + | accountBalance < BI.vaCapital cbcValidatorAdd = + return (TxReject InsufficientBalanceForBakerStake) + | not proofsValid = + return (TxReject InvalidProof) + | otherwise = do + (removedDelegator, removeStake) <- case cbcRemoveDelegator of + CTrue True -> do + cm <- getChainMetadata + return (True, RemoveExistingStake (slotTime cm)) + _ -> return (False, NoExistingStake) + addValidator senderAccountIndex removeStake cbcValidatorAdd <&> \case + Left failure -> rejectResult failure + Right () -> addResult removedDelegator cbcValidatorAdd + executeConfigure (CBCUpdate{..}, accountBalance) + | Just newCapital <- cbCapital, + accountBalance < newCapital = + return (TxReject InsufficientBalanceForBakerStake) + | not proofsValid = + return (TxReject InvalidProof) + | otherwise = do + cm <- getChainMetadata + updateValidator (slotTime cm) senderAccountIndex cbcValidatorUpdate <&> \case + Left failure -> rejectResult failure + Right changes -> updateResult changes + addResult removedDelegator BI.ValidatorAdd{vaCommissionRates = CommissionRates{..}, ..} = + TxSuccess $ + [DelegationRemoved (DelegatorId senderAccountIndex) senderAddress | removedDelegator] + ++ [ BakerAdded + { ebaBakerId = bid, + ebaAccount = senderAddress, + ebaSignKey = BI.bkuSignKey vaKeys, + ebaElectionKey = BI.bkuElectionKey vaKeys, + ebaAggregationKey = BI.bkuAggregationKey vaKeys, + ebaStake = vaCapital, + ebaRestakeEarnings = vaRestakeEarnings + }, + BakerSetRestakeEarnings bid senderAddress vaRestakeEarnings, + BakerSetOpenStatus bid senderAddress vaOpenForDelegation, + BakerSetMetadataURL bid senderAddress vaMetadataURL, + BakerSetTransactionFeeCommission bid senderAddress _transactionCommission, + BakerSetBakingRewardCommission bid senderAddress _bakingCommission, + BakerSetFinalizationRewardCommission bid senderAddress _finalizationCommission + ] + updateResult changes = + TxSuccess $ + changes <&> \case + BI.BakerConfigureStakeIncreased newStake -> + BakerStakeIncreased bid senderAddress newStake + BI.BakerConfigureStakeReduced newStake + | newStake == 0 -> BakerRemoved bid senderAddress + | otherwise -> BakerStakeDecreased bid senderAddress newStake + BI.BakerConfigureRestakeEarnings newRestakeEarnings -> + BakerSetRestakeEarnings bid senderAddress newRestakeEarnings + BI.BakerConfigureOpenForDelegation newOpenStatus -> + BakerSetOpenStatus bid senderAddress newOpenStatus + BI.BakerConfigureUpdateKeys BI.BakerKeyUpdate{..} -> + BakerKeysUpdated + { ebkuBakerId = bid, + ebkuAccount = senderAddress, + ebkuSignKey = bkuSignKey, + ebkuElectionKey = bkuElectionKey, + ebkuAggregationKey = bkuAggregationKey + } + BI.BakerConfigureMetadataURL newMetadataURL -> + BakerSetMetadataURL bid senderAddress newMetadataURL + BI.BakerConfigureTransactionFeeCommission transactionFeeCommission -> + BakerSetTransactionFeeCommission bid senderAddress transactionFeeCommission + BI.BakerConfigureBakingRewardCommission bakingRewardCommission -> + BakerSetBakingRewardCommission bid senderAddress bakingRewardCommission + BI.BakerConfigureFinalizationRewardCommission finalizationRewardCommission -> + BakerSetFinalizationRewardCommission bid senderAddress finalizationRewardCommission + rejectResult failure = + TxReject $! case failure of + BI.VCFStakeUnderThreshold -> StakeUnderMinimumThresholdForBaking + BI.VCFTransactionFeeCommissionNotInRange -> TransactionFeeCommissionNotInRange + BI.VCFBakingRewardCommissionNotInRange -> BakingRewardCommissionNotInRange + BI.VCFFinalizationRewardCommissionNotInRange -> FinalizationRewardCommissionNotInRange + BI.VCFDuplicateAggregationKey key -> DuplicateAggregationKey key + BI.VCFChangePending -> BakerInCooldown + +-- | Argument to the 'withDeposit' continuation for 'handleConfigureDelegation'. +data ConfigureDelegationCont (av :: AccountVersion) + = CDCAdd + { -- | When flexible cooldown is supported, we can add a delegator when there already is + -- a validator on the account, but we have to remove the validator first. This flag + -- indicates if there is a validator to remove. + cdcRemoveValidator :: !(Conditionally (SupportsFlexibleCooldown av) Bool), + -- | The parameters defining the delegator to add. + cdcDelegatorAdd :: !BI.DelegatorAdd + } + | CDCUpdate + { -- | The parameters defining the update to the delegator. + cdcDelegatorUpdate :: !BI.DelegatorUpdate + } +-- | Handler for a configure delegation transaction. handleConfigureDelegation :: + forall m. (PVSupportsDelegation (MPV m), SchedulerMonad m) => WithDepositContext m -> Maybe Amount -> @@ -2255,103 +2259,108 @@ handleConfigureDelegation :: Maybe DelegationTarget -> m (Maybe TransactionSummary) handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = - withDeposit wtc tickAndGetAccountBalance kWithAccountBalance + withDeposit wtc tickAndGetAccountBalance chargeAndExecute where senderAccount = wtc ^. wtcSenderAccount + senderAccountIndex = fst senderAccount + did = DelegatorId senderAccountIndex senderAddress = wtc ^. wtcSenderAddress - configureAddDelegationArg = - case (cdCapital, cdRestakeEarnings, cdDelegationTarget) of - (Just cdcCapital, _, _) - | cdcCapital == 0 -> - rejectTransaction InsufficientDelegationStake - (Just cdcCapital, Just cdcRestakeEarnings, Just cdcDelegationTarget) -> - return ConfigureAddDelegationCont{..} - _ -> - rejectTransaction MissingDelegationAddParameters - configureUpdateDelegationArg = return ConfigureUpdateDelegationCont - + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor (MPV m))) tickAndGetAccountBalance = do -- Charge the energy cost and then check the validity of the parameters. tickEnergy Cost.configureDelegationCost accountStake <- getAccountStake (snd senderAccount) - arg <- case accountStake of - AccountStakeNone -> configureAddDelegationArg - AccountStakeBaker ab -> - rejectTransaction $ - AlreadyABaker $ + arg :: (ConfigureDelegationCont (AccountVersionFor (MPV m))) <- case accountStake of + AccountStakeNone -> case mDelegatorAdd of + Just da | BI.daCapital da == 0 -> rejectTransaction InsufficientDelegationStake + Just da -> return (CDCAdd (conditionally flexibleCooldown False) da) + Nothing -> rejectTransaction MissingDelegationAddParameters + where + mDelegatorAdd = do + daCapital <- cdCapital + daRestakeEarnings <- cdRestakeEarnings + daDelegationTarget <- cdDelegationTarget + return BI.DelegatorAdd{..} + AccountStakeBaker ab -> case flexibleCooldown of + SFalse -> + rejectTransaction . AlreadyABaker $ ab ^. accountBakerInfo . bieBakerInfo . bakerIdentity + STrue -> case mDelegatorAdd of + Just da | BI.daCapital da == 0 -> rejectTransaction InsufficientDelegationStake + Just da -> return (CDCAdd (CTrue True) da) + Nothing -> rejectTransaction MissingDelegationAddParameters + where + mDelegatorAdd = do + let daCapital = fromMaybe (ab ^. stakedAmount) cdCapital + let daRestakeEarnings = fromMaybe (ab ^. stakeEarnings) cdRestakeEarnings + daDelegationTarget <- cdDelegationTarget + return BI.DelegatorAdd{..} AccountStakeDelegate _ -> - configureUpdateDelegationArg - (arg,) <$> getCurrentAccountTotalAmount senderAccount - kWithAccountBalance ls (ConfigureAddDelegationCont{..}, accountBalance) = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - if accountBalance < cdcCapital - then -- The balance is insufficient. - return (TxReject InsufficientBalanceForDelegationStake, energyCost, usedEnergy) - else do - -- The proof validates that the baker owns all the private keys, - -- thus we can try to create the baker. - let dca = - BI.DelegationConfigureAdd - { dcaCapital = cdcCapital, - dcaRestakeEarnings = cdcRestakeEarnings, - dcaDelegationTarget = cdcDelegationTarget + return $ + CDCUpdate + BI.DelegatorUpdate + { duCapital = cdCapital, + duRestakeEarnings = cdRestakeEarnings, + duDelegationTarget = cdDelegationTarget } - res <- configureDelegation (fst senderAccount) dca - kResult energyCost usedEnergy dca res - kWithAccountBalance ls (ConfigureUpdateDelegationCont, accountBalance) = do + (arg,) <$> getCurrentAccountTotalAmount senderAccount + chargeAndExecute ls argAndBalance = do (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) chargeExecutionCost senderAccount energyCost - if maybe False (accountBalance <) cdCapital - then return (TxReject InsufficientBalanceForDelegationStake, energyCost, usedEnergy) - else do - cm <- getChainMetadata - let dcu = - BI.DelegationConfigureUpdate - { dcuSlotTimestamp = slotTime cm, - dcuCapital = cdCapital, - dcuRestakeEarnings = cdRestakeEarnings, - dcuDelegationTarget = cdDelegationTarget - } - res <- configureDelegation (fst senderAccount) dcu - kResult energyCost usedEnergy dcu res - kResult energyCost usedEnergy BI.DelegationConfigureUpdate{} (BI.DCSuccess changes did) = do - let events = - changes <&> \case - BI.DelegationConfigureStakeIncreased newStake -> - DelegationStakeIncreased did senderAddress newStake - BI.DelegationConfigureStakeReduced newStake - | newStake == 0 -> DelegationRemoved did senderAddress - | otherwise -> DelegationStakeDecreased did senderAddress newStake - BI.DelegationConfigureRestakeEarnings newRestakeEarnings -> - DelegationSetRestakeEarnings did senderAddress newRestakeEarnings - BI.DelegationConfigureDelegationTarget newDelegationTarget -> - DelegationSetDelegationTarget did senderAddress newDelegationTarget - return (TxSuccess events, energyCost, usedEnergy) - kResult energyCost usedEnergy BI.DelegationConfigureAdd{..} (BI.DCSuccess _ did) = do - let events = - [ DelegationAdded{edaDelegatorId = did, edaAccount = senderAddress}, - DelegationSetDelegationTarget did senderAddress dcaDelegationTarget, - DelegationSetRestakeEarnings did senderAddress dcaRestakeEarnings, - DelegationStakeIncreased did senderAddress dcaCapital - ] - return (TxSuccess events, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCInvalidAccount = - return (TxReject (InvalidAccountReference senderAddress), energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCChangePending = - return (TxReject DelegatorInCooldown, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCInvalidDelegator = - return (TxReject (NotADelegator senderAddress), energyCost, usedEnergy) - kResult energyCost usedEnergy _ (BI.DCInvalidDelegationTarget bid) = - return (TxReject (DelegationTargetNotABaker bid), energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCPoolStakeOverThreshold = - return (TxReject StakeOverMaximumThresholdForPool, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCPoolOverDelegated = - return (TxReject PoolWouldBecomeOverDelegated, energyCost, usedEnergy) - kResult energyCost usedEnergy _ BI.DCPoolClosed = - return (TxReject PoolClosed, energyCost, usedEnergy) + result <- executeConfigure argAndBalance + return (result, energyCost, usedEnergy) + executeConfigure (CDCAdd{..}, accountBalance) + | accountBalance < BI.daCapital cdcDelegatorAdd = + return (TxReject InsufficientBalanceForDelegationStake) + | otherwise = do + (removedValidator, removeStake) <- case cdcRemoveValidator of + CTrue True -> do + cm <- getChainMetadata + return (True, RemoveExistingStake (slotTime cm)) + _ -> return (False, NoExistingStake) + addDelegator senderAccountIndex removeStake cdcDelegatorAdd <&> \case + Left failure -> rejectResult failure + Right () -> addResult removedValidator cdcDelegatorAdd + executeConfigure (CDCUpdate{..}, accountBalance) + | Just newCapital <- cdCapital, + accountBalance < newCapital = + return (TxReject InsufficientBalanceForDelegationStake) + | otherwise = do + cm <- getChainMetadata + updateDelegator (slotTime cm) senderAccountIndex cdcDelegatorUpdate <&> \case + Left failure -> rejectResult failure + Right changes -> updateResult changes + + addResult removedValidator BI.DelegatorAdd{..} = + TxSuccess $ + [BakerRemoved (BakerId senderAccountIndex) senderAddress | removedValidator] + ++ [ DelegationAdded + { edaDelegatorId = did, + edaAccount = senderAddress + }, + DelegationSetDelegationTarget did senderAddress daDelegationTarget, + DelegationSetRestakeEarnings did senderAddress daRestakeEarnings, + DelegationStakeIncreased did senderAddress daCapital + ] + updateResult changes = + TxSuccess $ + changes <&> \case + BI.DelegationConfigureStakeIncreased newStake -> + DelegationStakeIncreased did senderAddress newStake + BI.DelegationConfigureStakeReduced newStake + | newStake == 0 -> DelegationRemoved did senderAddress + | otherwise -> DelegationStakeDecreased did senderAddress newStake + BI.DelegationConfigureRestakeEarnings newRestakeEarnings -> + DelegationSetRestakeEarnings did senderAddress newRestakeEarnings + BI.DelegationConfigureDelegationTarget newDelegationTarget -> + DelegationSetDelegationTarget did senderAddress newDelegationTarget + rejectResult = \case + BI.DCFChangePending -> TxReject DelegatorInCooldown + BI.DCFInvalidDelegationTarget bid -> TxReject (DelegationTargetNotABaker bid) + BI.DCFPoolStakeOverThreshold -> TxReject StakeOverMaximumThresholdForPool + BI.DCFPoolOverDelegated -> TxReject PoolWouldBecomeOverDelegated + BI.DCFPoolClosed -> TxReject PoolClosed -- | Remove the baker for an account. The logic is as follows: -- diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index b5894ed35..66858e1fb 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -82,6 +82,15 @@ class (Monad m) => StaticInformation m where -- | Get the current exchange rates, that is the Euro per NRG, micro CCD per Euro and the energy rate. getExchangeRates :: m ExchangeRates +-- | When adding a validator or delegator to an account, this indicates whether the account has +-- an existing delegator or validator that must be removed. +data RemoveExistingStake + = -- | The existing stake will be removed. The timestamp is that of the current block. + RemoveExistingStake !Timestamp + | -- | The account has no existing stake. + NoExistingStake + deriving (Eq, Show) + -- | Information needed to execute transactions in the form that is easy to use. class (Monad m, StaticInformation m, AccountOperations m, ContractStateOperations m, ModuleQuery m, MonadLogger m, MonadProtocolVersion m, TVer.TransactionVerifier m) => @@ -192,23 +201,69 @@ class BakerAdd -> m BakerAddResult - -- | From chain parameters version >= 1, this operation is used to add/remove/update a baker. + -- | From chain parameters version 1, this operation adds a validator on an account. -- For details of the behaviour and return values, see - -- 'Concordium.GlobalState.BlockState.bsoConfigureBaker'. - configureBaker :: + -- 'Concordium.GlobalState.BlockState.bsoAddValidator'. + -- + -- PRECONDITION: + -- * The account must exist; + -- * The account must not already be a validator; + -- * The flag must indicate if the account is currently a delegator, which will be removed; + -- * The account must have sufficient balance to cover the stake. + addValidator :: + (PVSupportsDelegation (MPV m)) => + AccountIndex -> + -- | Whether the account already has a delegator, which will be removed in the process. + RemoveExistingStake -> + ValidatorAdd -> + m (Either ValidatorConfigureFailure ()) + + -- | From chain parameters version 1, this operation updates or removes a validator on an + -- account. For details of the behaviour and return values, see + -- 'Concordium.GlobalState.BlockState.bsoUpdateValidator'. + -- + -- PRECONDITION: + -- * The account must exist; + -- * The account must be a validator; + -- * The account must have sufficient balance to cover the new stake. + updateValidator :: (PVSupportsDelegation (MPV m)) => + Timestamp -> AccountIndex -> - BakerConfigure -> - m BakerConfigureResult + ValidatorUpdate -> + m (Either ValidatorConfigureFailure [BakerConfigureUpdateChange]) - -- | From chain parameters version >= 1, this operation is used to add/remove/update a delegator. + -- | From chain parameters version 1, this operation adds a delegator on an account. -- For details of the behaviour and return values, see - -- 'Concordium.GlobalState.BlockState.bsoConfigureDelegation'. - configureDelegation :: + -- 'Concordium.GlobalState.BlockState.bsoAddDelegator'. + -- + -- PRECONDITION: + -- * The account must exist; + -- * The account must not already be a delegator; + -- * The flag must indicate if the account is currently a validator, which will be removed; + -- * The account must have sufficient balance to cover the stake. + addDelegator :: + (PVSupportsDelegation (MPV m)) => + AccountIndex -> + -- | Whether the account already has a validator, which will be removed in the process. + RemoveExistingStake -> + DelegatorAdd -> + m (Either DelegatorConfigureFailure ()) + + -- | From chain parameters version 1, this operation updates or removes a delegator on an + -- account. For details of the behaviour and return values, see + -- 'Concordium.GlobalState.BlockState.bsoUpdateDelegator'. + -- + -- PRECONDITION: + -- * The account must exist; + -- * The account must be a delegator; + -- * The account must have sufficient balance to cover the new stake. + updateDelegator :: (PVSupportsDelegation (MPV m)) => + Timestamp -> AccountIndex -> - DelegationConfigure -> - m DelegationConfigureResult + DelegatorUpdate -> + m (Either DelegatorConfigureFailure [DelegationConfigureUpdateChange]) -- | Remove the baker associated with an account. -- The removal takes effect after a cooling-off period. diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index c2502b838..d32b7591d 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -17,6 +17,7 @@ import qualified Data.Kind as DK import Lens.Micro.Platform import Concordium.GlobalState.Account +import qualified Concordium.GlobalState.BakerInfo as BI import qualified Concordium.GlobalState.BlockState as BS import Concordium.GlobalState.TreeState import Concordium.Logger @@ -293,19 +294,83 @@ instance ssBlockState .= s' return ret - {-# INLINE configureBaker #-} - configureBaker ai bconfig = do + {-# INLINE addValidator #-} + addValidator ai removeDelegator vadd = do s <- use ssBlockState - (ret, s') <- lift (BS.bsoConfigureBaker s ai bconfig) + (s', res) <- lift (doAdd s) ssBlockState .= s' - return ret - - {-# INLINE configureDelegation #-} - configureDelegation ai dconfig = do + return res + where + doAdd s0 | RemoveExistingStake ts <- removeDelegator = do + -- We need to remove the delegator first. + -- We take a snapshot of the state so we can rollback if the add fails. + snapshot <- BS.bsoSnapshotState s0 + rdRes <- BS.bsoUpdateDelegator s0 ts ai BI.delegatorRemove + case rdRes of + Left e -> + -- Removing the delegator cannot fail, since the account must have a delegator. + error $ "addValidator: Failed to remove delegator: " ++ show e + Right (_, s1) -> do + res <- BS.bsoAddValidator s1 ai vadd + case res of + Left e -> do + -- Rollback the state to the snapshot. + s' <- BS.bsoRollback s1 snapshot + return (s', Left e) + Right s' -> return (s', Right ()) + doAdd s = do + res <- BS.bsoAddValidator s ai vadd + return $! case res of + Left e -> (s, Left e) + Right s' -> (s', Right ()) + + {-# INLINE updateValidator #-} + updateValidator ts ai vadd = do + s <- use ssBlockState + lift (BS.bsoUpdateValidator s ts ai vadd) >>= \case + Left e -> return (Left e) + Right (events, s') -> do + ssBlockState .= s' + return (Right events) + + {-# INLINE addDelegator #-} + addDelegator ai removeValidator dadd = do s <- use ssBlockState - (ret, s') <- lift (BS.bsoConfigureDelegation s ai dconfig) + (s', res) <- lift (doAdd s) ssBlockState .= s' - return ret + return res + where + doAdd s0 | RemoveExistingStake ts <- removeValidator = do + -- We need to remove the validator first. + -- We take a snapshot of the state so we can rollback if the add fails. + snapshot <- BS.bsoSnapshotState s0 + rvRes <- BS.bsoUpdateValidator s0 ts ai BI.validatorRemove + case rvRes of + Left e -> + -- Removing the validator cannot fail, since the account must have a validator. + error $ "addDelegator: Failed to remove validator: " ++ show e + Right (_, s1) -> do + res <- BS.bsoAddDelegator s1 ai dadd + case res of + Left e -> do + -- Rollback the state to the snapshot. + s' <- BS.bsoRollback s1 snapshot + return (s', Left e) + Right s' -> return (s', Right ()) + doAdd s = do + res <- BS.bsoAddDelegator s ai dadd + return $! case res of + Left e -> (s, Left e) + Right s' -> (s', Right ()) + + {-# INLINE updateDelegator #-} + updateDelegator ts ai dadd = do + s <- use ssBlockState + lift (BS.bsoUpdateDelegator s ts ai dadd) >>= \case + Left e -> return (Left e) + Right (events, s') -> do + ssBlockState .= s' + return (Right events) {-# INLINE removeBaker #-} removeBaker ai = do diff --git a/concordium-consensus/src/Concordium/Scheduler/Runner.hs b/concordium-consensus/src/Concordium/Scheduler/Runner.hs index f7d341429..3905cc0a4 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Runner.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Runner.hs @@ -120,6 +120,8 @@ transactionHelper t = return $ signTx keys meta (Types.encodePayload Types.EncryptedAmountTransferWithMemo{..}) (TJSON meta TransferWithScheduleAndMemo{..} keys) -> return $ signTx keys meta (Types.encodePayload Types.TransferWithScheduleAndMemo{..}) + (TJSON meta ConfigureBaker{..} keys) -> + return $ signTx keys meta (Types.encodePayload Types.ConfigureBaker{..}) (TJSON meta ConfigureDelegation{..} keys) -> return $ signTx keys meta (Types.encodePayload Types.ConfigureDelegation{..}) @@ -232,6 +234,24 @@ data PayloadJSON twswmMemo :: !Memo, twswmSchedule :: ![(Timestamp, Amount)] } + | ConfigureBaker + { -- | The equity capital of the baker + cbCapital :: !(Maybe Amount), + -- | Whether the baker's earnings are restaked + cbRestakeEarnings :: !(Maybe Bool), + -- | Whether the pool is open for delegators + cbOpenForDelegation :: !(Maybe Types.OpenStatus), + -- | The key/proof pairs to verify baker. + cbKeysWithProofs :: !(Maybe Types.BakerKeysWithProofs), + -- | The URL referencing the baker's metadata. + cbMetadataURL :: !(Maybe UrlText), + -- | The commission the pool owner takes on transaction fees. + cbTransactionFeeCommission :: !(Maybe AmountFraction), + -- | The commission the pool owner takes on baking rewards. + cbBakingRewardCommission :: !(Maybe AmountFraction), + -- | The commission the pool owner takes on finalization rewards. + cbFinalizationRewardCommission :: !(Maybe AmountFraction) + } | ConfigureDelegation { -- | The capital delegated to the pool. cdCapital :: !(Maybe Amount), diff --git a/concordium-consensus/src/Concordium/Skov/Monad.hs b/concordium-consensus/src/Concordium/Skov/Monad.hs index 39d2724c9..d479d1be5 100644 --- a/concordium-consensus/src/Concordium/Skov/Monad.hs +++ b/concordium-consensus/src/Concordium/Skov/Monad.hs @@ -111,6 +111,8 @@ data UpdateResult ResultInsufficientFunds | -- | The consensus message is a result of double signing, indicating malicious behaviour. ResultDoubleSign + | -- | The consensus has thrown an exception and entered an unrecoverable state. + ResultConsensusFailure deriving (Eq, Show) -- | Maps a 'TV.VerificationResult' to the corresponding 'UpdateResult' type. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 08d74272b..7dd07d627 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -46,7 +46,7 @@ import Test.Hspec import Test.QuickCheck import Prelude hiding (fail) -type PV = 'P5 +type PV = 'P6 newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) @@ -278,7 +278,10 @@ tests lvl = describe "GlobalStateTests.Accounts" pbscAccountMap <- LMDBAccountMap.openDatabase (dir "accountmap") return PersistentBlockStateContext{..} ) - (closeBlobStore . pbscBlobStore) + ( \PersistentBlockStateContext{..} -> do + closeBlobStore pbscBlobStore + LMDBAccountMap.closeDatabase pbscAccountMap + ) kont ) $ do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountsMigrationP6ToP7.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountsMigrationP6ToP7.hs index 81674183a..47b4436bb 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountsMigrationP6ToP7.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountsMigrationP6ToP7.hs @@ -28,6 +28,7 @@ import Concordium.Types.Accounts import qualified Concordium.Crypto.BlockSignature as Sig import qualified Concordium.Crypto.BlsSignature as Bls +import Concordium.Crypto.EncryptedTransfers import qualified Concordium.Crypto.VRF as VRF import Concordium.Genesis.Data import Concordium.GlobalState.Account @@ -75,6 +76,14 @@ dummyPersisingAccountData seed = addr = accountAddressFromSeed seed encryptionKey = toRawEncryptionKey (makeEncryptionKey dummyCryptographicParameters (credId cred)) +-- | A dummy account encrypted amount, with a non-trivial self balance. +-- This is used to test the migration of accounts with non-trivial encrypted balances. +dummyAccountEncryptedAmount :: AccountEncryptedAmount +dummyAccountEncryptedAmount = + initialAccountEncryptedAmount + { _selfAmount = encryptAmountZeroRandomness dummyCryptographicParameters 10 + } + -- | Create a test account with the given persisting data and stake. -- The balance of the account is set to 1 billion CCD (10^15 uCCD). testAccount :: @@ -88,7 +97,7 @@ testAccount persisting stake = { _accountPersisting = Transient.makeAccountPersisting persisting, _accountNonce = minNonce, _accountAmount = 1_000_000_000_000_000, - _accountEncryptedAmount = initialAccountEncryptedAmount, + _accountEncryptedAmount = dummyAccountEncryptedAmount, _accountReleaseSchedule = Transient.emptyAccountReleaseSchedule, _accountStaking = stake, _accountStakeCooldown = Transient.emptyCooldownQueue (accountVersion @av) @@ -198,10 +207,13 @@ setupTestAccounts = do (ReduceStake (reducedStake 13) (PendingChangeEffectiveV1 9000)) a14 <- mkDelegatorAccount 14 DelegatePassive (RemoveStake (PendingChangeEffectiveV1 10_000)) accounts0 <- emptyAccounts - foldM - (\accts a -> snd <$> putNewAccount a accts) - accounts0 - [a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14] + accounts1 <- + foldM + (\accts a -> snd <$> putNewAccount a accts) + accounts0 + [a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14] + -- Store and load the accounts to ensure the data is flushed. + loadRef =<< storeRef accounts1 where mkBakerAccount accIdx pc = makePersistentAccount $ @@ -359,8 +371,10 @@ tests = describe "GlobalStateTests.AccountsMigrationP6ToP7" where createPBSC dir i = do pbscBlobStore <- createBlobStore (dir ("blockstate" ++ i ++ ".dat")) - pbscAccountCache <- newAccountCache 100 - pbscModuleCache <- M.newModuleCache 100 + -- Set the account cache size to 0 to ensure that the accounts are always loaded from the + -- blob store. + pbscAccountCache <- newAccountCache 0 + pbscModuleCache <- M.newModuleCache 0 pbscAccountMap <- LMDBAccountMap.openDatabase (dir ("accountmap" ++ i)) return PersistentBlockStateContext{..} destroyPBSC PersistentBlockStateContext{..} = do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/BlockStateHelpers.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/BlockStateHelpers.hs index 3b728e096..c596468f0 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/BlockStateHelpers.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/BlockStateHelpers.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -11,6 +10,7 @@ module GlobalStateTests.BlockStateHelpers where import Control.Exception import Control.Monad.IO.Class +import Data.Bool.Singletons import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set @@ -40,6 +40,11 @@ import qualified Concordium.GlobalState.Persistent.ReleaseSchedule as ReleaseSch import qualified Concordium.GlobalState.Persistent.Trie as Trie import Concordium.Scheduler.DummyData +import qualified Concordium.Crypto.SHA256 as Hash +import Concordium.GlobalState.Parameters +import qualified Concordium.GlobalState.Persistent.Accounts as Accounts +import Concordium.GlobalState.Persistent.Bakers +import Concordium.Types.SeedState import GlobalStateTests.Accounts (NoLoggerT (..), runNoLoggerT) -- | Construct a dummy account with the specified cooldowns. @@ -64,81 +69,82 @@ data AccountConfig (av :: AccountVersion) = AccountConfig { acAccountIndex :: AccountIndex, acAmount :: Amount, acStaking :: StakeDetails av, + acPoolInfo :: Maybe BakerPoolInfo, acCooldowns :: Cooldowns } deriving (Show) --- | Helper function for creating the initial stake for an account. -makePersistentAccountStakeEnduring :: - (MonadBlobStore m, AVSupportsFlexibleCooldown av, AVSupportsDelegation av, IsAccountVersion av) => - -- | The 'StakeDetails' for the account. - StakeDetails av -> - -- | The account index. - AccountIndex -> - -- | The 'SV1.PersistentAccountStakeEnduring' and the amount staked. - m (SV1.PersistentAccountStakeEnduring av, Amount) -makePersistentAccountStakeEnduring StakeDetailsNone _ = return (SV1.PersistentAccountStakeEnduringNone, 0) -makePersistentAccountStakeEnduring StakeDetailsBaker{..} ai = do - let fulBaker = DummyData.mkFullBaker (fromIntegral ai) (BakerId ai) ^. _1 - paseBakerInfo <- - refMake - BakerInfoExV1 - { _bieBakerInfo = fulBaker ^. bakerInfo, - _bieBakerPoolInfo = poolInfo +dummyBakerPoolInfo :: BakerPoolInfo +dummyBakerPoolInfo = + BakerPoolInfo + { _poolOpenStatus = OpenForAll, + _poolMetadataUrl = UrlText "Some URL", + _poolCommissionRates = + -- Note: these commission rates are significant for the ConfigureValidator tests + CommissionRates + { _finalizationCommission = makeAmountFraction 350, + _bakingCommission = makeAmountFraction 550, + _transactionCommission = makeAmountFraction 150 } - return - ( SV1.PersistentAccountStakeEnduringBaker - { paseBakerRestakeEarnings = sdRestakeEarnings, - paseBakerPendingChange = NoChange, - .. - }, - sdStakedCapital - ) + } + +-- | Set the staking details for an account. +setAccountStakeDetails :: + (MonadBlobStore m, AVSupportsDelegation av, IsAccountVersion av) => + AccountIndex -> + StakeDetails av -> + Maybe BakerPoolInfo -> + PersistentAccount av -> + m (PersistentAccount av) +setAccountStakeDetails _ StakeDetailsNone _ acc = return acc +setAccountStakeDetails ai StakeDetailsBaker{..} mPoolInfo acc = + setAccountStakePendingChange sdPendingChange + =<< addAccountBakerV1 bie sdStakedCapital sdRestakeEarnings acc where - poolInfo = - BakerPoolInfo - { _poolOpenStatus = OpenForAll, - _poolMetadataUrl = UrlText "Some URL", - _poolCommissionRates = - CommissionRates - { _finalizationCommission = makeAmountFraction 50_000, - _bakingCommission = makeAmountFraction 50_000, - _transactionCommission = makeAmountFraction 50_000 - } + bie = + BakerInfoExV1 + { _bieBakerInfo = fulBaker ^. bakerInfo, + _bieBakerPoolInfo = poolInfo + } + fulBaker = DummyData.mkFullBaker (fromIntegral ai) (BakerId ai) ^. _1 + poolInfo = fromMaybe dummyBakerPoolInfo mPoolInfo +setAccountStakeDetails ai StakeDetailsDelegator{..} _ acc = + setAccountStakePendingChange sdPendingChange =<< addAccountDelegator del acc + where + del = + AccountDelegationV1 + { _delegationTarget = sdDelegationTarget, + _delegationStakedAmount = sdStakedCapital, + _delegationStakeEarnings = sdRestakeEarnings, + _delegationPendingChange = NoChange, + _delegationIdentity = DelegatorId ai } -makePersistentAccountStakeEnduring StakeDetailsDelegator{..} ai = do - return - ( SV1.PersistentAccountStakeEnduringDelegator - { paseDelegatorId = DelegatorId ai, - paseDelegatorRestakeEarnings = sdRestakeEarnings, - paseDelegatorTarget = sdDelegationTarget, - paseDelegatorPendingChange = NoChange - }, - sdStakedCapital - ) -- | Create a dummy 'PersistentAccount' from an 'AccountConfig'. makeDummyAccount :: forall av m. ( IsAccountVersion av, MonadBlobStore m, - SupportsFlexibleCooldown av ~ 'True + SupportsDelegation av ~ 'True ) => AccountConfig av -> m (PersistentAccount av) makeDummyAccount AccountConfig{..} = do - makeTestAccountFromSeed @av acAmount (fromIntegral acAccountIndex) >>= \case - PAV3 acc -> do - let ed = SV1.enduringData acc - cq <- CooldownQueue.makeCooldownQueue acCooldowns - (staking, stakeAmount) <- makePersistentAccountStakeEnduring acStaking acAccountIndex - newEnduring <- - refMake - =<< SV1.rehashAccountEnduringData - ed{SV1.paedStakeCooldown = cq, SV1.paedStake = staking} - return $ - PAV3 - acc{SV1.accountEnduringData = newEnduring, SV1.accountStakedAmount = stakeAmount} + acc0 <- makeTestAccountFromSeed @av acAmount (fromIntegral acAccountIndex) + acc1 <- setAccountStakeDetails acAccountIndex acStaking acPoolInfo acc0 + case sSupportsFlexibleCooldown (accountVersion @av) of + STrue -> case acc1 of + PAV3 acc -> do + let ed = SV1.enduringData acc + cq <- CooldownQueue.makeCooldownQueue acCooldowns + newEnduring <- + refMake + =<< SV1.rehashAccountEnduringData + ed{SV1.paedStakeCooldown = cq} + return $ + PAV3 + acc{SV1.accountEnduringData = newEnduring} + SFalse -> return acc1 -- | Run a block state computation using a temporary directory for the blob store and account map. runTestBlockState :: @@ -202,3 +208,71 @@ checkCooldowns pbs = do actualPrePreCooldowns <- Set.fromList <$> Cooldown.loadAccountList (aic ^. Cooldown.prePreCooldown) liftIO $ assertEqual "Pre-pre-cooldown set" prePreCooldowns actualPrePreCooldowns return (reverse theCooldowns) + +dummySeedState :: forall pv. SProtocolVersion pv -> SeedState (SeedStateVersionFor pv) +dummySeedState spv = case sSeedStateVersionFor spv of + SSeedStateVersion0 -> initialSeedStateV0 (Hash.hash "NONCE") 1000 + SSeedStateVersion1 -> initialSeedStateV1 (Hash.hash "NONCE") 1000 + +-- | Representation of the active bakers in the block state. +data ActiveBakers = ActiveBakers + { abActiveBakers :: Map.Map BakerId ([DelegatorId], Amount), + abAggregationKeys :: [BakerAggregationVerifyKey], + abPassiveDelegators :: ([DelegatorId], Amount), + abTotalActiveCapital :: Amount + } + deriving (Eq, Show) + +-- | Load the active bakers from the block state. +-- Note, 'abTotalActiveCapital' will be 0 if the block state is from a version that does not store +-- this value. +loadActiveBakers :: forall av m. (MonadBlobStore m, IsAccountVersion av) => BufferedRef (PersistentActiveBakers av) -> m ActiveBakers +loadActiveBakers pabRef = do + PersistentActiveBakers{..} <- refLoad pabRef + bakers0 <- Trie.toMap _activeBakers + abActiveBakers <- mapM loadActiveDelegators bakers0 + abAggregationKeys <- Map.keys <$> Trie.toMap _aggregationKeys + abPassiveDelegators <- loadActiveDelegators _passiveDelegators + let abTotalActiveCapital = case _totalActiveCapital of + TotalActiveCapitalV0 -> 0 + TotalActiveCapitalV1 capital -> capital + return ActiveBakers{..} + where + loadActiveDelegators :: PersistentActiveDelegators av -> m ([DelegatorId], Amount) + loadActiveDelegators PersistentActiveDelegatorsV0 = return ([], 0) + loadActiveDelegators (PersistentActiveDelegatorsV1 delegators capital) = do + dlgs <- Trie.keysAsc delegators + return (dlgs, capital) + +-- | Check that the active bakers in the block state are correct for the accounts by constructing +-- a fresh block state from the accounts and comparing the active bakers. +checkActiveBakers :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> m () +checkActiveBakers bs = do + bsp <- loadPBS bs + theAccounts <- Accounts.foldAccountsDesc (\l a -> pure (a : l)) [] (bspAccounts bsp) + newBSP <- loadPBS . hpbsPointers =<< mkInitialState theAccounts + expectedActiveBakers <- loadActiveBakers (_birkActiveBakers $ bspBirkParameters newBSP) + actualActiveBakers <- loadActiveBakers (_birkActiveBakers $ bspBirkParameters bsp) + liftIO $ assertEqual "ActiveBakers" expectedActiveBakers actualActiveBakers + where + spv = protocolVersion @pv + mkInitialState accounts = + initialPersistentState @pv + (dummySeedState spv) + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + (withIsAuthorizationsVersionForPV spv DummyData.dummyKeyCollection) + DummyData.dummyChainParameters + +dumpState :: (SupportsPersistentState pv m) => HashedPersistentBlockState pv -> m () +dumpState hpbs = do + bsp <- loadPBS (hpbsPointers hpbs) + liftIO $ putStrLn "== Accounts ==" + + Accounts.foldAccounts (\_ -> showPA) () (bspAccounts bsp) + return () + where + showPA pa = do + liftIO . print =<< toTransientAccount pa diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureDelegator.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureDelegator.hs new file mode 100644 index 000000000..4c15c3eca --- /dev/null +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureDelegator.hs @@ -0,0 +1,533 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Tests for adding and updating delegators. +module GlobalStateTests.ConfigureDelegator where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Writer.CPS +import Data.Bool.Singletons +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Ratio +import GlobalStateTests.BlockStateHelpers +import Lens.Micro.Platform +import Test.Hspec +import Test.QuickCheck + +import Concordium.Types +import Concordium.Types.Accounts +import Concordium.Types.Execution +import Concordium.Types.Option +import Concordium.Types.Parameters + +import Concordium.GlobalState.Account +import Concordium.GlobalState.BakerInfo +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.CooldownQueue +import qualified Concordium.GlobalState.DummyData as DummyData +import Concordium.GlobalState.Persistent.BlockState + +-- | Some non-trivial cooldowns that may be set on an account for testing. +initialTestCooldowns :: Cooldowns +initialTestCooldowns = + Cooldowns + { inCooldown = Map.fromList [(1000, 2), (2000, 2)], + prePreCooldown = Present 2, + preCooldown = Present 2 + } + +-- | The balance for accounts used in the tests. +baseAmount :: Amount +baseAmount = 100 + +-- | The baseline stake used in the tests. The test account use (small) multiples of this amount. +-- Setting this to 1 makes it easier to catch off-by-one errors in the tests. +baseStake :: Amount +baseStake = 1 + +-- | Generate a list of test accounts with at least one baker, one delegator and one +-- non-staking account. +genTestAccounts :: forall av. (IsAccountVersion av, AVSupportsDelegation av) => Gen [AccountConfig av] +genTestAccounts = do + let nAccounts = 10 + let accountIndices = [0 .. nAccounts - 1] + nBakers <- choose (1, nAccounts - 2) + bakerIndices <- take nBakers <$> shuffle accountIndices + nDelegators <- choose (1, nAccounts - nBakers - 1) + let nonBakers = filter (`notElem` bakerIndices) accountIndices + delegatorIndices <- take nDelegators <$> shuffle nonBakers + -- Favour open pools to ensure the case of delegating to a closed pool is not overrepresented. + bakerStatuses <- + vectorOf nAccounts $ + frequency + [ (8, return OpenForAll), + (1, return ClosedForAll), + (1, return ClosedForNew) + ] + forM accountIndices $ \ai -> do + stake <- (baseStake *) . fromInteger <$> choose (1, 10) + -- Delegators can only delegate to pools that are not closed for all. + delTarget <- + elements $ + DelegatePassive + : [DelegateToBaker (fromIntegral bi) | bi <- bakerIndices, bakerStatuses !! bi /= ClosedForAll] + let poolStatus = bakerStatuses !! ai + (cooldowns, pendingChange) <- case sSupportsFlexibleCooldown (accountVersion @av) of + STrue -> (,NoChange) <$> elements [emptyCooldowns, initialTestCooldowns] + SFalse -> + (emptyCooldowns,) + <$> oneof + [ return NoChange, + ReduceStake . fromInteger <$> choose (1, fromIntegral stake) <*> pure (PendingChangeEffectiveV1 1000), + return $ RemoveStake (PendingChangeEffectiveV1 1000) + ] + return $ + AccountConfig + { acAccountIndex = fromIntegral ai, + acAmount = baseAmount, + acStaking = + if ai `elem` bakerIndices + then + StakeDetailsBaker + { sdStakedCapital = stake, + sdRestakeEarnings = True, + sdPendingChange = pendingChange + } + else + if ai `elem` delegatorIndices + then + StakeDetailsDelegator + { sdStakedCapital = stake, + sdRestakeEarnings = True, + sdPendingChange = pendingChange, + sdDelegationTarget = delTarget + } + else StakeDetailsNone, + acPoolInfo = Just dummyBakerPoolInfo{_poolOpenStatus = poolStatus}, + acCooldowns = cooldowns + } + +-- | A configuration for testing the delegator functionality. +data DelegatorTestConfig av = DelegatorTestConfig + { -- | The configuration of account to use. These must be sequentially indexed. + dtcAccounts :: [AccountConfig av], + -- | The index of the account to use in a test. It must be present in 'dtcAccounts', and + -- other conditions may apply depending on the test. + dtcUseAccount :: AccountIndex, + -- | The capital bound to use in the test. + dtcCapitalBound :: CapitalBound, + -- | The leverage bound to use in the test. + dtcLeverageBound :: LeverageFactor + } + deriving (Show) + +-- | Determine if the target is open for delegation. Returns 'Nothing' if the target is not a baker, +-- 'Just True' if the target is open for delegation and 'Just False' if the target is closed for +-- further delegation. +dtcTargetOpen :: DelegatorTestConfig av -> DelegationTarget -> Maybe Bool +dtcTargetOpen _ DelegatePassive = Just True +dtcTargetOpen DelegatorTestConfig{..} (DelegateToBaker bi) + | fromIntegral bi < length dtcAccounts, + AccountConfig{acStaking = StakeDetailsBaker{}, ..} <- dtcAccounts !! fromIntegral bi = + case acPoolInfo of + Just BakerPoolInfo{_poolOpenStatus = OpenForAll} -> Just True + Just _ -> Just False + _ -> Nothing + | otherwise = Nothing + +-- | The total active stake of bakers and delegators in the configuration. +dtcTotalStake :: DelegatorTestConfig av -> Amount +dtcTotalStake DelegatorTestConfig{..} = + sum $ map (accountStakedCapital . acStaking) dtcAccounts + where + accountStakedCapital StakeDetailsBaker{..} = sdStakedCapital + accountStakedCapital StakeDetailsDelegator{..} = sdStakedCapital + accountStakedCapital _ = 0 + +-- | Get the total active stake and delegated stake of a baker. (Or 'Nothing' if the baker does +-- not exist as an active baker.) +dtcBakerStake :: DelegatorTestConfig av -> BakerId -> Maybe (Amount, Amount) +dtcBakerStake DelegatorTestConfig{..} bi = (,delegatorStakes) <$> bkrStake + where + bkrStake + | fromIntegral bi < length dtcAccounts, + AccountConfig{acStaking = StakeDetailsBaker{..}} <- dtcAccounts !! fromIntegral bi = + Just sdStakedCapital + | otherwise = Nothing + delegatorStakes = sum $ map delStake dtcAccounts + delStake AccountConfig{acStaking = StakeDetailsDelegator{..}} + | sdDelegationTarget == DelegateToBaker bi = sdStakedCapital + delStake _ = 0 + +-- | The cooldowns for the accounts in the configuration. +dtcCooldowns :: DelegatorTestConfig av -> [Cooldowns] +dtcCooldowns DelegatorTestConfig{..} = map acCooldowns dtcAccounts + +-- | Show the expected result of a test. This is used for labelling test cases. +showExpectedResult :: Either DelegatorConfigureFailure a -> String +showExpectedResult (Left DCFInvalidDelegationTarget{}) = "DCFInvalidDelegationTarget" +showExpectedResult (Left DCFPoolClosed) = "DCFPoolClosed" +showExpectedResult (Left DCFPoolStakeOverThreshold) = "DCFPoolStakeOverThreshold" +showExpectedResult (Left DCFPoolOverDelegated) = "DCFPoolOverDelegated" +showExpectedResult (Left DCFChangePending) = "DCFChangePending" +showExpectedResult (Right _) = "Success" + +-- | Get the expected result of adding a delegator. +expectedAddResult :: DelegatorTestConfig av -> DelegatorAdd -> Either DelegatorConfigureFailure () +expectedAddResult dtc@DelegatorTestConfig{..} DelegatorAdd{..} + | Just False <- targetOpen = Left DCFPoolClosed + | Nothing <- targetOpen, + DelegateToBaker bid <- daDelegationTarget = + Left $ DCFInvalidDelegationTarget bid + | DelegateToBaker bid <- daDelegationTarget, + Just (bkrStake, delStake) <- dtcBakerStake dtc bid = + if delStake + daCapital + bkrStake > applyLeverageFactor dtcLeverageBound bkrStake + then Left DCFPoolStakeOverThreshold + else + if bkrStake + delStake + daCapital > takeFraction (theCapitalBound dtcCapitalBound) (dtcTotalStake dtc + daCapital) + then Left DCFPoolOverDelegated + else Right () + | otherwise = Right () + where + targetOpen = dtcTargetOpen dtc daDelegationTarget + +-- | Run a test of 'bsoAddDelegator' with the given configuration and delegator to add. +-- In the configuration, 'dtcUseAccount' must be the index of an account that is neither a baker +-- nor a delegator. +runAddDelegatorTest :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + DelegatorTestConfig (AccountVersionFor pv) -> + DelegatorAdd -> + IO () +runAddDelegatorTest spv dtc@DelegatorTestConfig{..} da@DelegatorAdd{..} = runTestBlockState @pv $ do + initialAccounts <- mapM makeDummyAccount dtcAccounts + initialBS <- mkInitialState initialAccounts + res <- bsoAddDelegator initialBS dtcUseAccount da + let expect = expectedAddResult dtc da + liftIO $ void res `shouldBe` expect + forM_ res $ \bs -> do + checkActiveBakers bs + () <- case flexibleCooldown of + STrue -> do + newCooldowns <- checkCooldowns bs + liftIO $ + newCooldowns + `shouldBe` ( dtcCooldowns dtc + & ix (fromIntegral dtcUseAccount) %~ reactivateCooldownAmount daCapital + ) + SFalse -> return () + acc <- fromJust <$> bsoGetAccountByIndex bs dtcUseAccount + let expectAccountDelegation = + AccountDelegationV1 + { _delegationIdentity = DelegatorId dtcUseAccount, + _delegationStakedAmount = daCapital, + _delegationStakeEarnings = daRestakeEarnings, + _delegationTarget = daDelegationTarget, + _delegationPendingChange = NoChange + } + actualAccountDelegation <- getAccountDelegator acc + liftIO $ actualAccountDelegation `shouldBe` Just expectAccountDelegation + where + flexibleCooldown = sSupportsFlexibleCooldown (sAccountVersionFor spv) + chainParams = + DummyData.dummyChainParameters @(ChainParametersVersionFor pv) + & cpPoolParameters . ppCapitalBound .~ dtcCapitalBound + & cpPoolParameters . ppLeverageBound .~ dtcLeverageBound + mkInitialState accounts = + hpbsPointers + <$> initialPersistentState @pv + (dummySeedState spv) + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + (withIsAuthorizationsVersionForPV spv DummyData.dummyKeyCollection) + chainParams + +-- | Test 'bsoAddDelegator' with a random configurations. +testAddDelegator :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + Property +testAddDelegator spv = withMaxSuccess 1000 $ property $ do + accounts <- genTestAccounts @(AccountVersionFor pv) + useAccount <- elements [acc | acc <- accounts, isUnstaked acc] + capital <- + oneof + [ (baseStake *) . fromInteger <$> choose (1, 20), + fromInteger <$> choose (1, fromIntegral baseAmount) + ] + restake <- arbitrary + let delegateToAccount acc = DelegateToBaker (BakerId (acAccountIndex acc)) + let chooseNonBaker = elements [delegateToAccount acc | acc <- accounts, not (isBaker acc)] + let chooseBaker = elements [delegateToAccount acc | acc <- accounts, isBaker acc] + let chooseInvalidAccount = + elements + [ DelegateToBaker (BakerId (fromIntegral i)) + | i <- [length accounts .. length accounts + 10] + ] + -- Favour delegating to a baker, as this covers the most interesting cases. + target <- + frequency + [ (1, return DelegatePassive), + (1, chooseNonBaker), + (8, chooseBaker), + (1, chooseInvalidAccount) + ] + let delegatorAdd = + DelegatorAdd + { daCapital = capital, + daRestakeEarnings = restake, + daDelegationTarget = target + } + capitalBound <- CapitalBound . AmountFraction . fromInteger <$> choose (1, 100_000) + leverageDen <- choose (1, 10) + leverageNum <- choose (leverageDen, 100) + let leverageBound = LeverageFactor $ leverageNum % leverageDen + let config = + DelegatorTestConfig + { dtcAccounts = accounts, + dtcUseAccount = acAccountIndex useAccount, + dtcCapitalBound = capitalBound, + dtcLeverageBound = leverageBound + } + let lab + | target == DelegatePassive = "Passive delegation" + | otherwise = showExpectedResult $ expectedAddResult config delegatorAdd + return $ + label lab $ + counterexample (show config) $ + counterexample (show delegatorAdd) $ + ioProperty $ + runAddDelegatorTest spv config delegatorAdd + where + isUnstaked AccountConfig{acStaking = StakeDetailsNone} = True + isUnstaked _ = False + isBaker AccountConfig{acStaking = StakeDetailsBaker{}} = True + isBaker _ = False + +-- | Get the expected result of updating a delegator. +expectedUpdateResult :: + forall av. + (IsAccountVersion av) => + DelegatorTestConfig av -> + DelegatorUpdate -> + Either DelegatorConfigureFailure [DelegationConfigureUpdateChange] +expectedUpdateResult dtc@DelegatorTestConfig{..} DelegatorUpdate{..} + | Just t <- duDelegationTarget, + oldTarget /= t, + Just False <- dtcTargetOpen dtc t = + Left DCFPoolClosed + | Just t@(DelegateToBaker bid) <- duDelegationTarget, + Nothing <- dtcTargetOpen dtc t = + Left $ DCFInvalidDelegationTarget bid + | Just _ <- duCapital, changePending = Left DCFChangePending + | DelegateToBaker bid <- newTarget, + newEffectiveCapital > 0, + oldTarget /= newTarget || oldCapital < newEffectiveCapital, + Just (bkrStake, delStake) <- dtcBakerStake dtc bid = + if + | applyAmountDelta deltaPool (delStake + bkrStake) + > applyLeverageFactor dtcLeverageBound bkrStake -> + Left DCFPoolStakeOverThreshold + | applyAmountDelta deltaPool (bkrStake + delStake) + > takeFraction + (theCapitalBound dtcCapitalBound) + (applyAmountDelta delta $ dtcTotalStake dtc) -> + Left DCFPoolOverDelegated + | otherwise -> Right expectChanges + | otherwise = Right expectChanges + where + flexibleCooldown = case sSupportsFlexibleCooldown (accountVersion @av) of + STrue -> True + SFalse -> False + senderAccount = dtcAccounts !! fromIntegral dtcUseAccount + (oldCapital, oldTarget, changePending) = case acStaking senderAccount of + StakeDetailsDelegator{..} -> (sdStakedCapital, sdDelegationTarget, sdPendingChange /= NoChange) + _ -> error "Account is not a delegator" + newEffectiveCapital + | not flexibleCooldown, + Just newCap <- duCapital, + newCap < oldCapital = + oldCapital + | otherwise = fromMaybe oldCapital duCapital + delta = amountDiff newEffectiveCapital oldCapital + deltaPool + | Just t <- duDelegationTarget, t /= oldTarget = amountToDelta newEffectiveCapital + | otherwise = delta + newTarget = fromMaybe oldTarget duDelegationTarget + expectChanges = execWriter $ do + forM_ duDelegationTarget $ tell . (: []) . DelegationConfigureDelegationTarget + forM_ duRestakeEarnings $ tell . (: []) . DelegationConfigureRestakeEarnings + forM_ duCapital $ \newCap -> + if newCap >= oldCapital + then tell [DelegationConfigureStakeIncreased newCap] + else tell [DelegationConfigureStakeReduced newCap] + +-- | Run a test of 'bsoUpdateDelegator' with the given configuration and delegator update. +runUpdateDelegatorTest :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + DelegatorTestConfig (AccountVersionFor pv) -> + DelegatorUpdate -> + IO () +runUpdateDelegatorTest spv dtc@DelegatorTestConfig{..} du@DelegatorUpdate{..} = runTestBlockState @pv $ do + initialAccounts <- mapM makeDummyAccount dtcAccounts + initialBS <- mkInitialState initialAccounts + res <- bsoUpdateDelegator initialBS 5000 dtcUseAccount du + let expect = expectedUpdateResult dtc du + liftIO $ fst <$> res `shouldBe` expect + forM_ res $ \(_, bs) -> do + checkActiveBakers bs + () <- case flexibleCooldown of + STrue -> do + newCooldowns <- checkCooldowns bs + liftIO $ + newCooldowns + `shouldBe` ( dtcCooldowns dtc + & ix (fromIntegral dtcUseAccount) %~ updateCooldown + ) + SFalse -> return () + acc <- fromJust <$> bsoGetAccountByIndex bs dtcUseAccount + let (newPendingChange, newEffectiveCapital) = case flexibleCooldown of + SFalse + | Just newCapital <- duCapital, + newCapital == 0 -> + (RemoveStake (PendingChangeEffectiveV1 (24 * 60 * 60 * 1000 + 5000)), oldCapital) + | Just newCapital <- duCapital, + newCapital < oldCapital -> + (ReduceStake newCapital (PendingChangeEffectiveV1 (24 * 60 * 60 * 1000 + 5000)), oldCapital) + _ -> (oldPendingChange, fromMaybe oldCapital duCapital) + + let expectAccountDelegation' = + AccountDelegationV1 + { _delegationIdentity = DelegatorId dtcUseAccount, + _delegationStakedAmount = newEffectiveCapital, + _delegationStakeEarnings = fromMaybe oldRestake duRestakeEarnings, + _delegationTarget = fromMaybe oldTarget duDelegationTarget, + _delegationPendingChange = newPendingChange + } + let expectAccountDelegation = case flexibleCooldown of + STrue | Just newCapital <- duCapital, newCapital == 0 -> Nothing + _ -> Just expectAccountDelegation' + actualAccountDelegation <- getAccountDelegator acc + liftIO $ actualAccountDelegation `shouldBe` expectAccountDelegation + where + flexibleCooldown = sSupportsFlexibleCooldown (sAccountVersionFor spv) + chainParams = + DummyData.dummyChainParameters @(ChainParametersVersionFor pv) + & cpPoolParameters . ppCapitalBound .~ dtcCapitalBound + & cpPoolParameters . ppLeverageBound .~ dtcLeverageBound + (oldCapital, oldRestake, oldTarget, oldPendingChange) = + case acStaking (dtcAccounts !! fromIntegral dtcUseAccount) of + StakeDetailsDelegator{..} -> + (sdStakedCapital, sdRestakeEarnings, sdDelegationTarget, sdPendingChange) + _ -> + error "Account is not a delegator" + updateCooldown = case duCapital of + Just newCapital + | newCapital > oldCapital -> reactivateCooldownAmount (newCapital - oldCapital) + | newCapital < oldCapital -> addPrePreCooldown (oldCapital - newCapital) + _ -> id + mkInitialState accounts = + hpbsPointers + <$> initialPersistentState @pv + (dummySeedState spv) + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + (withIsAuthorizationsVersionForPV spv DummyData.dummyKeyCollection) + chainParams + +-- | Test 'bsoUpdateDelegator' with a random configurations. +testUpdateDelegator :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + Property +testUpdateDelegator spv = withMaxSuccess 1000 $ property $ do + accounts <- genTestAccounts @(AccountVersionFor pv) + useAccount <- elements [acc | acc <- accounts, isDelegator acc] + capital <- + frequency + [ (8, Just . (baseStake *) . fromInteger <$> choose (1, 20)), + (4, Just . fromInteger <$> choose (1, fromIntegral baseAmount)), + (2, return Nothing), + (1, return $ Just 0) + ] + restake <- arbitrary + let chooseNonBaker = elements [DelegateToBaker (BakerId (acAccountIndex acc)) | acc <- accounts, not (isBaker acc)] + let chooseBaker = elements [DelegateToBaker (BakerId (acAccountIndex acc)) | acc <- accounts, isBaker acc] + let chooseInvalidAccount = elements [DelegateToBaker (BakerId (fromIntegral i)) | i <- [length accounts .. length accounts + 10]] + target <- + frequency + [ (1, return $ Just DelegatePassive), + (1, Just <$> chooseNonBaker), + (8, Just <$> chooseBaker), + (1, return Nothing), + (1, Just <$> chooseInvalidAccount) + ] + let delegatorUpdate = + DelegatorUpdate + { duCapital = capital, + duRestakeEarnings = restake, + duDelegationTarget = target + } + capitalBound <- CapitalBound . AmountFraction . fromInteger <$> choose (1, 100_000) + leverageDen <- choose (1, 10) + leverageNum <- choose (leverageDen, 100) + let leverageBound = LeverageFactor $ leverageNum % leverageDen + let config = + DelegatorTestConfig + { dtcAccounts = accounts, + dtcUseAccount = acAccountIndex useAccount, + dtcCapitalBound = capitalBound, + dtcLeverageBound = leverageBound + } + let lab + | target == Just DelegatePassive = "Passive delegation" + | otherwise = showExpectedResult $ expectedUpdateResult config delegatorUpdate + return $ + label lab $ + counterexample (show config) $ + counterexample (show delegatorUpdate) $ + ioProperty $ + runUpdateDelegatorTest spv config delegatorUpdate + where + isDelegator AccountConfig{acStaking = StakeDetailsDelegator{}} = True + isDelegator _ = False + isBaker AccountConfig{acStaking = StakeDetailsBaker{}} = True + isBaker _ = False + +tests :: Spec +tests = parallel $ describe "Configure delegator" $ do + describe "P6" $ do + it "bsoAddDelegator" $ testAddDelegator SP6 + it "bsoUpdateDelegator" $ testUpdateDelegator SP6 + describe "P7" $ do + it "bsoAddDelegator" $ testAddDelegator SP7 + it "bsoUpdateDelegator" $ testUpdateDelegator SP7 diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureValidator.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureValidator.hs new file mode 100644 index 000000000..36da93483 --- /dev/null +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/ConfigureValidator.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module GlobalStateTests.ConfigureValidator where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Writer.CPS +import Data.Bool.Singletons +import qualified Data.Map.Strict as Map +import Data.Maybe +import Lens.Micro.Platform +import Test.Hspec +import Test.QuickCheck + +import qualified Concordium.Crypto.BlockSignature as Sig +import qualified Concordium.Crypto.BlsSignature as Bls +import qualified Concordium.Crypto.VRF as VRF +import Concordium.Types +import Concordium.Types.Accounts +import qualified Concordium.Types.DummyData as DummyData +import Concordium.Types.Execution +import Concordium.Types.Option +import Concordium.Types.Parameters + +import Concordium.GlobalState.Account +import Concordium.GlobalState.BakerInfo +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.CooldownQueue +import qualified Concordium.GlobalState.DummyData as DummyData +import Concordium.GlobalState.Persistent.BlockState + +import GlobalStateTests.BlockStateHelpers + +-- | Test accounts used for testing the 'bsoAddValidator' function. +-- The first account is a regular account, the second account is a baker account. +addValidatorTestAccounts :: + -- | Whether the first account should have cooldowns. + Bool -> + [AccountConfig pv] +addValidatorTestAccounts withCooldowns = + [ AccountConfig + { acAccountIndex = 0, + acAmount = 1_000_000_000_000, + acStaking = StakeDetailsNone, + acPoolInfo = Nothing, + acCooldowns = if withCooldowns then initialTestCooldowns else emptyCooldowns + }, + AccountConfig + { acAccountIndex = 1, + acAmount = 1_000_000_000_000, + acStaking = + StakeDetailsBaker + { sdStakedCapital = 500_000_000_000, + sdRestakeEarnings = True, + sdPendingChange = NoChange + }, + acPoolInfo = Nothing, + acCooldowns = emptyCooldowns + } + ] + +-- | Conditions that can trigger a specific error in 'bsoAddValidator' or 'bsoUpdateValidator'. +data ValidatorConditions = ValidatorConditions + { vcUnderThreshold :: Bool, + vcTransactionFeeNotInRange :: Bool, + vcBakingRewardNotInRange :: Bool, + vcFinalizationRewardNotInRange :: Bool, + vcAggregationKeyDuplicate :: Bool + } + deriving (Show) + +-- | All possible 'ValidatorConditions' configurations. +validatorConditions :: [ValidatorConditions] +validatorConditions = do + vcUnderThreshold <- [True, False] + vcTransactionFeeNotInRange <- [True, False] + vcBakingRewardNotInRange <- [True, False] + vcFinalizationRewardNotInRange <- [True, False] + vcAggregationKeyDuplicate <- [True, False] + return ValidatorConditions{..} + +-- | Derive a 'BakerKeyUpdate' from a seed. +makeBakerKeyUpdate :: Int -> BakerKeyUpdate +makeBakerKeyUpdate seed = + BakerKeyUpdate + { bkuSignKey = Sig.verifyKey $ DummyData.bakerSignKey seed, + bkuAggregationKey = Bls.derivePublicKey $ DummyData.bakerAggregationKey seed, + bkuElectionKey = VRF.publicKey $ DummyData.bakerElectionKey seed + } + +-- | Test 'bsoAddValidator' in a variety of cases that exercise the different error conditions, +-- and ensure that the behaviour is as expected (including on success). +testAddValidatorAllCases :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + Spec +testAddValidatorAllCases spv = describe "bsoAddValidator" $ do + forM_ validatorConditions $ \vc -> do + it (show vc) $ runTest False vc + when supportCooldown $ it (show vc <> " with cooldown") $ runTest True vc + where + supportCooldown = supportsFlexibleCooldown $ accountVersionFor $ demoteProtocolVersion (protocolVersion @pv) + minEquity = 1_000_000_000 + chainParams = + DummyData.dummyChainParameters @(ChainParametersVersionFor pv) + & cpPoolParameters . ppMinimumEquityCapital .~ minEquity + & cpPoolParameters . ppCommissionBounds + .~ CommissionRanges + { _transactionCommissionRange = InclusiveRange (makeAmountFraction 100) (makeAmountFraction 200), + _finalizationCommissionRange = InclusiveRange (makeAmountFraction 300) (makeAmountFraction 400), + _bakingCommissionRange = InclusiveRange (makeAmountFraction 500) (makeAmountFraction 600) + } + mkInitialState accounts = + hpbsPointers + <$> initialPersistentState @pv + (dummySeedState (protocolVersion @pv)) + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + (withIsAuthorizationsVersionForPV spv DummyData.dummyKeyCollection) + chainParams + runTest withCooldown ValidatorConditions{..} = runTestBlockState @pv $ do + let va = + ValidatorAdd + { vaKeys = if vcAggregationKeyDuplicate then badKeys else goodKeys, + vaCapital = if vcUnderThreshold then minEquity - 1 else minEquity, + vaRestakeEarnings = True, + vaOpenForDelegation = OpenForAll, + vaMetadataURL = UrlText "Some URL", + vaCommissionRates = + CommissionRates + { _finalizationCommission = makeAmountFraction $ if vcFinalizationRewardNotInRange then 100 else 300, + _bakingCommission = makeAmountFraction $ if vcBakingRewardNotInRange then 100 else 500, + _transactionCommission = makeAmountFraction $ if vcTransactionFeeNotInRange then 300 else 100 + } + } + initialAccounts <- mapM makeDummyAccount (addValidatorTestAccounts withCooldown) + initialBS <- mkInitialState initialAccounts + res <- bsoAddValidator initialBS 0 va + let expect + | vcUnderThreshold = Left VCFStakeUnderThreshold + | vcTransactionFeeNotInRange = Left VCFTransactionFeeCommissionNotInRange + | vcBakingRewardNotInRange = Left VCFBakingRewardCommissionNotInRange + | vcFinalizationRewardNotInRange = Left VCFFinalizationRewardCommissionNotInRange + | vcAggregationKeyDuplicate = Left (VCFDuplicateAggregationKey (bkuAggregationKey (vaKeys va))) + | otherwise = Right () + liftIO $ void res `shouldBe` expect + forM_ res $ \bs -> do + -- Check the active bakers are correct + checkActiveBakers bs + () <- case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of + STrue -> do + -- Check that the cooldowns are correct + newCooldowns <- checkCooldowns bs + let bakerInitialCooldowns + | withCooldown = initialTestCooldowns + | otherwise = emptyCooldowns + let bakerExpectedCooldowns = reactivateCooldownAmount (vaCapital va) bakerInitialCooldowns + liftIO $ newCooldowns `shouldBe` [bakerExpectedCooldowns, emptyCooldowns] + SFalse -> return () + acc <- bsoGetAccountByIndex bs 0 + let expectedBaker = + AccountBaker + { _stakedAmount = vaCapital va, + _stakeEarnings = vaRestakeEarnings va, + _bakerPendingChange = NoChange, + _accountBakerInfo = + BakerInfoExV1 + { _bieBakerInfo = + BakerInfo + { _bakerSignatureVerifyKey = bkuSignKey (vaKeys va), + _bakerElectionVerifyKey = bkuElectionKey (vaKeys va), + _bakerAggregationVerifyKey = bkuAggregationKey (vaKeys va), + _bakerIdentity = BakerId 0 + }, + _bieBakerPoolInfo = + BakerPoolInfo + { _poolOpenStatus = vaOpenForDelegation va, + _poolMetadataUrl = vaMetadataURL va, + _poolCommissionRates = vaCommissionRates va + } + } + } + bkr <- getAccountBaker (fromJust acc) + liftIO $ bkr `shouldBe` Just expectedBaker + return () + goodKeys = makeBakerKeyUpdate 0 + badKeys = makeBakerKeyUpdate 1 + +-- | The initial stake amount for the test accounts. +initialStakedAmount :: Amount +initialStakedAmount = 500_000_000_000 + +-- | Some non-trivial cooldowns that may be set on an account for testing. +initialTestCooldowns :: Cooldowns +initialTestCooldowns = + Cooldowns + { inCooldown = Map.fromList [(1000, 100_000_000_000), (2000, 100_000_000_000)], + prePreCooldown = Present 2000, + preCooldown = Present 8000 + } + +-- | Test account set up for 'bsoUpdateValidator'. The first two accounts are validators, and the +-- third is delegating to the first. +updateValidatorTestAccounts :: + forall av. + (IsAccountVersion av, AVSupportsDelegation av) => + Bool -> + [AccountConfig av] +updateValidatorTestAccounts pendingChangeOrCooldown = + [ AccountConfig + { acAccountIndex = 0, + acAmount = 1_000_000_000_000, + acStaking = + StakeDetailsBaker + { sdStakedCapital = initialStakedAmount, + sdRestakeEarnings = True, + sdPendingChange = pendingChange + }, + acPoolInfo = Nothing, + acCooldowns = cooldowns + }, + AccountConfig + { acAccountIndex = 1, + acAmount = 1_000_000_000_000, + acStaking = + StakeDetailsBaker + { sdStakedCapital = initialStakedAmount, + sdRestakeEarnings = True, + sdPendingChange = NoChange + }, + acPoolInfo = Nothing, + acCooldowns = emptyCooldowns + }, + AccountConfig + { acAccountIndex = 2, + acAmount = 1_000_000_000_001, + acStaking = + StakeDetailsDelegator + { sdStakedCapital = initialStakedAmount, + sdRestakeEarnings = True, + sdPendingChange = NoChange, + sdDelegationTarget = DelegateToBaker 0 + }, + acPoolInfo = Nothing, + acCooldowns = emptyCooldowns + } + ] + where + (pendingChange, cooldowns) + | pendingChangeOrCooldown = case sSupportsFlexibleCooldown (accountVersion @av) of + STrue -> (NoChange, initialTestCooldowns) + SFalse -> (ReduceStake (initialStakedAmount `div` 2) (PendingChangeEffectiveV1 1000), emptyCooldowns) + | otherwise = (NoChange, emptyCooldowns) + +-- | A configuration for testing 'bsoUpdateValidator'. +data ValidatorUpdateConfig = ValidatorUpdateConfig + { -- | The update to perform + vucValidatorUpdate :: ValidatorUpdate, + -- | Conditions that should trigger a specific error + vucValidatorConditions :: ValidatorConditions, + -- | Whether the account should have a pending change or cooldown set initially + vucPendingChangeOrCooldown :: Bool, + -- | A description of the configuration + vucDescription :: String + } + +instance Show ValidatorUpdateConfig where + show = vucDescription + +-- | Test cases for updating a validator. These cover a very broad combination of updates to +-- different fields. +validatorUpdateCases :: [ValidatorUpdateConfig] +validatorUpdateCases = do + (vuKeys, vuKeysDesc, vcAggregationKeyDuplicate) <- + [ (Nothing, "none", False), + (Just (makeBakerKeyUpdate 0), "old keys", False), + (Just (makeBakerKeyUpdate 2), "fresh keys", False), + (Just (makeBakerKeyUpdate 1), "duplicate keys", True) + ] + (vuCapital, vuCapitalDesc, vcUnderThreshold) <- + [ (Just 600_000_000_000, "increase", False), + (Just initialStakedAmount, "same", False), + (Just 1_000_000_000, "decrease", False), + (Just 999_999_999, "insufficient", True), + (Just 0, "zero", False), + (Nothing, "no change", False) + ] + (vuRestakeEarnings, vuRestakeEarningsDesc) <- + [ (Just True, "restake"), + (Just False, "no restake"), + (Nothing, "no change") + ] + (vuOpenForDelegation, vuOpenForDelegationDesc) <- + [ (Just OpenForAll, "open"), + (Just ClosedForAll, "closed for all"), + (Just ClosedForNew, "closed for new"), + (Nothing, "no change") + ] + (vuMetadataURL, vuMetadataURLDesc) <- + [ (Just (UrlText "Some URL"), "same URL"), + (Just (UrlText "Some new URL"), "new URL"), + (Nothing, "no change") + ] + (vuTransactionFeeCommission, vuTransactionFeeCommissionDesc, vcTransactionFeeNotInRange) <- + [ (Just (makeAmountFraction 100), "in range", False), + (Just (makeAmountFraction 201), "out of range", True), + (Just (makeAmountFraction 150), "same", False), + (Nothing, "no change", False) + ] + (vuBakingRewardCommission, vuBakingRewardCommissionDesc, vcBakingRewardNotInRange) <- + [ (Just (makeAmountFraction 500), "in range", False), + (Just (makeAmountFraction 400), "out of range", True), + (Just (makeAmountFraction 550), "same", False), + (Nothing, "no change", False) + ] + (vuFinalizationRewardCommission, vuFinalizationRewardCommissionDesc, vcFinalizationRewardNotInRange) <- + [ (Just (makeAmountFraction 300), "in range", False), + (Just (makeAmountFraction 401), "out of range", True), + (Just (makeAmountFraction 350), "same", False), + (Nothing, "no change", False) + ] + let vucValidatorUpdate = ValidatorUpdate{..} + let vucValidatorConditions = ValidatorConditions{..} + vucPendingChangeOrCooldown <- [True, False] + let vucDescription = + "keys: " + <> vuKeysDesc + <> ", capital: " + <> vuCapitalDesc + <> ", restake: " + <> vuRestakeEarningsDesc + <> ", open: " + <> vuOpenForDelegationDesc + <> ", URL: " + <> vuMetadataURLDesc + <> ", transaction fee: " + <> vuTransactionFeeCommissionDesc + <> ", baking reward: " + <> vuBakingRewardCommissionDesc + <> ", finalization reward: " + <> vuFinalizationRewardCommissionDesc + <> ( if vucPendingChangeOrCooldown + then ", pending change/cooldown" + else ", no pending change/cooldown" + ) + return $ ValidatorUpdateConfig{..} + +-- | Commission ranges that narrowly include the commission rates used in the test cases. +narrowCommissionRanges :: CommissionRanges +narrowCommissionRanges = + CommissionRanges + { _transactionCommissionRange = InclusiveRange (makeAmountFraction 100) (makeAmountFraction 200), + _finalizationCommissionRange = InclusiveRange (makeAmountFraction 300) (makeAmountFraction 400), + _bakingCommissionRange = InclusiveRange (makeAmountFraction 500) (makeAmountFraction 600) + } + +-- | Commission ranges that include the full range of possible commission rates. +fullCommissionRanges :: CommissionRanges +fullCommissionRanges = + CommissionRanges + { _transactionCommissionRange = fullRange, + _finalizationCommissionRange = fullRange, + _bakingCommissionRange = fullRange + } + where + fullRange = InclusiveRange (makeAmountFraction 0) (makeAmountFraction 100_000) + +-- | Test updating a validator in various possible ways. +testUpdateValidator :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + -- | If 'True', test all cases. + Bool -> + Spec +testUpdateValidator spv True = describe "bsoUpdateValidator" $ do + forM_ validatorUpdateCases $ \conf -> do + it (show conf) $ runUpdateValidatorTest spv narrowCommissionRanges conf +testUpdateValidator spv False = do + it "bsoUpdateValidator (random cases)" $ + withMaxSuccess 1000 $ + forAll (elements validatorUpdateCases) $ + runUpdateValidatorTest spv narrowCommissionRanges + +-- | This test case is to detect possible confusion between the different commission rates. +testUpdateValidatorOverlappingCommissions :: + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + SpecWith () +testUpdateValidatorOverlappingCommissions spv = + it "bsoUpdateValidator - overlapping commissions" $ + forAll genCases $ + runUpdateValidatorTest spv fullCommissionRanges + where + genCases = do + let options = [Nothing, Just (AmountFraction 150), Just (AmountFraction 350), Just (AmountFraction 550), Just (AmountFraction 100_000)] + vuTransactionFeeCommission <- elements options + vuBakingRewardCommission <- elements options + vuFinalizationRewardCommission <- elements options + let vucValidatorUpdate = + ValidatorUpdate + { vuKeys = Nothing, + vuCapital = Nothing, + vuRestakeEarnings = Nothing, + vuOpenForDelegation = Nothing, + vuMetadataURL = Nothing, + .. + } + let vucPendingChangeOrCooldown = False + let vucValidatorConditions = + ValidatorConditions + { vcUnderThreshold = False, + vcTransactionFeeNotInRange = False, + vcBakingRewardNotInRange = False, + vcFinalizationRewardNotInRange = False, + vcAggregationKeyDuplicate = False + } + let vucDescription = + "transaction fee: " + <> show vuTransactionFeeCommission + <> ", baking reward: " + <> show vuBakingRewardCommission + <> ", finalization reward: " + <> show vuFinalizationRewardCommission + return ValidatorUpdateConfig{..} + +-- | Run a test on 'bsoUpdateValidator', checking the behaviour is as expected. +runUpdateValidatorTest :: + forall pv. + ( IsProtocolVersion pv, + SupportsDelegation (AccountVersionFor pv) ~ 'True, + PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 + ) => + SProtocolVersion pv -> + CommissionRanges -> + ValidatorUpdateConfig -> + IO () +runUpdateValidatorTest spv commissionRanges ValidatorUpdateConfig{vucValidatorUpdate = vu, vucValidatorConditions = vc, ..} = runTestBlockState @pv $ do + initialAccounts <- mapM makeDummyAccount (updateValidatorTestAccounts vucPendingChangeOrCooldown) + initialBS <- mkInitialState initialAccounts + initialAccountBaker <- fmap fromJust . getAccountBaker . fromJust =<< bsoGetAccountByIndex initialBS 0 + res <- bsoUpdateValidator initialBS 1000 0 vu + let expect + | vcAggregationKeyDuplicate vc = Left (VCFDuplicateAggregationKey (bkuAggregationKey (fromJust $ vuKeys vu))) + | vcTransactionFeeNotInRange vc = Left VCFTransactionFeeCommissionNotInRange + | vcBakingRewardNotInRange vc = Left VCFBakingRewardCommissionNotInRange + | vcFinalizationRewardNotInRange vc = Left VCFFinalizationRewardCommissionNotInRange + | vucPendingChangeOrCooldown, + isJust (vuCapital vu), + not $ supportsFlexibleCooldown $ accountVersionFor $ demoteProtocolVersion (protocolVersion @pv) = + Left VCFChangePending + | vcUnderThreshold vc = Left VCFStakeUnderThreshold + | otherwise = Right () + liftIO $ void res `shouldBe` expect + forM_ res $ \(changes, bs) -> do + -- We check that the changes are as expected. + let expectChanges = execWriter $ do + forM_ (vuKeys vu) $ \keys -> tell [BakerConfigureUpdateKeys keys] + forM_ (vuRestakeEarnings vu) $ \restake -> tell [BakerConfigureRestakeEarnings restake] + forM_ (vuOpenForDelegation vu) $ \open -> tell [BakerConfigureOpenForDelegation open] + forM_ (vuMetadataURL vu) $ \url -> tell [BakerConfigureMetadataURL url] + forM_ (vuTransactionFeeCommission vu) $ \fee -> tell [BakerConfigureTransactionFeeCommission fee] + forM_ (vuBakingRewardCommission vu) $ \fee -> tell [BakerConfigureBakingRewardCommission fee] + forM_ (vuFinalizationRewardCommission vu) $ \fee -> tell [BakerConfigureFinalizationRewardCommission fee] + forM_ (vuCapital vu) $ \capital -> + tell $ + if capital >= initialStakedAmount + then [BakerConfigureStakeIncreased capital] + else [BakerConfigureStakeReduced capital] + liftIO $ changes `shouldBe` expectChanges + -- Check the active bakers are correct + checkActiveBakers bs + () <- case flexibleCooldown of + STrue -> do + -- Check that the cooldowns are correct + newCooldowns <- checkCooldowns bs + let bakerInitialCooldowns + | vucPendingChangeOrCooldown = initialTestCooldowns + | otherwise = emptyCooldowns + let bakerExpectedCooldowns = case vuCapital vu of + Just newCapital -> case newCapital `compare` initialStakedAmount of + LT -> addPrePreCooldown (initialStakedAmount - newCapital) bakerInitialCooldowns + EQ -> bakerInitialCooldowns + GT -> reactivateCooldownAmount (newCapital - initialStakedAmount) bakerInitialCooldowns + _ -> bakerInitialCooldowns + liftIO $ newCooldowns `shouldBe` [bakerExpectedCooldowns, emptyCooldowns, emptyCooldowns] + when (vuCapital vu == Just 0) $ do + -- Check that account 2 delegates to passive now + acc2 <- fromJust <$> bsoGetAccountByIndex bs 2 + getAccountDelegator acc2 >>= \case + Just del -> + liftIO $ (del ^. delegationTarget) `shouldBe` DelegatePassive + Nothing -> liftIO $ expectationFailure "Account 2 should have a delegator" + SFalse -> return () + acc0 <- fromJust <$> bsoGetAccountByIndex bs 0 + let updateCapital newCapital + | newCapital < initialStakedAmount, + SFalse <- flexibleCooldown = + bakerPendingChange + .~ (if newCapital == 0 then RemoveStake else ReduceStake newCapital) + (PendingChangeEffectiveV1 (24 * 60 * 60 * 1000 + 1000)) + | otherwise = stakedAmount .~ newCapital + let expectedAccountBaker + | STrue <- flexibleCooldown, vuCapital vu == Just 0 = Nothing + | otherwise = + Just $ + initialAccountBaker + & maybe + id + ( \keys -> + (bakerElectionVerifyKey .~ bkuElectionKey keys) + . (bakerSignatureVerifyKey .~ bkuSignKey keys) + . (bakerAggregationVerifyKey .~ bkuAggregationKey keys) + ) + (vuKeys vu) + & maybe id updateCapital (vuCapital vu) + & maybe id (stakeEarnings .~) (vuRestakeEarnings vu) + & maybe id (poolOpenStatus .~) (vuOpenForDelegation vu) + & maybe id (poolMetadataUrl .~) (vuMetadataURL vu) + & maybe id (poolCommissionRates . finalizationCommission .~) (vuFinalizationRewardCommission vu) + & maybe id (poolCommissionRates . bakingCommission .~) (vuBakingRewardCommission vu) + & maybe id (poolCommissionRates . transactionCommission .~) (vuTransactionFeeCommission vu) + actualAccountBaker <- getAccountBaker acc0 + liftIO $ actualAccountBaker `shouldBe` expectedAccountBaker + where + flexibleCooldown = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) + minEquity = 1_000_000_000 + chainParams = + DummyData.dummyChainParameters @(ChainParametersVersionFor pv) + & cpPoolParameters . ppMinimumEquityCapital .~ minEquity + & cpPoolParameters . ppCommissionBounds + .~ commissionRanges + mkInitialState accounts = + hpbsPointers + <$> initialPersistentState @pv + (dummySeedState (protocolVersion @pv)) + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + (withIsAuthorizationsVersionForPV spv DummyData.dummyKeyCollection) + chainParams + +tests :: Word -> Spec +tests lvl = parallel $ describe "Validator" $ do + describe "P6" $ do + testAddValidatorAllCases SP6 + testUpdateValidator SP6 (lvl > 1) + testUpdateValidatorOverlappingCommissions SP6 + describe "P7" $ do + testAddValidatorAllCases SP7 + testUpdateValidator SP7 (lvl > 1) + testUpdateValidatorOverlappingCommissions SP7 diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs index 3749a6887..4c095ac77 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs @@ -123,42 +123,50 @@ createAccountWith a bs = do (,accIndex) <$> bsoModifyAccount bs' (emptyAccountUpdate accIndex & auAmount ?~ a) -- | Add a baker with the given staked amount. -addBakerWith :: Amount -> (PBS.PersistentBlockState PV, AccountIndex) -> ThisMonadConcrete PV (BakerConfigureResult, (PBS.PersistentBlockState PV, AccountIndex)) +addBakerWith :: + Amount -> + (PBS.PersistentBlockState PV, AccountIndex) -> + ThisMonadConcrete PV (Either ValidatorConfigureFailure (PBS.PersistentBlockState PV, AccountIndex)) addBakerWith am (bs, ai) = do a <- BlockSig.verifyKey <$> liftIO BlockSig.newKeyPair b <- Bls.derivePublicKey <$> liftIO Bls.generateSecretKey c <- VRF.publicKey <$> liftIO VRF.newKeyPair let conf = - BakerConfigureAdd - { bcaKeys = BakerKeyUpdate a b c, - bcaCapital = am, - bcaRestakeEarnings = False, - bcaOpenForDelegation = ClosedForAll, - bcaMetadataURL = emptyUrlText, - bcaTransactionFeeCommission = makeAmountFraction 0, - bcaBakingRewardCommission = makeAmountFraction 0, - bcaFinalizationRewardCommission = makeAmountFraction 0 + ValidatorAdd + { vaKeys = BakerKeyUpdate a b c, + vaCapital = am, + vaRestakeEarnings = False, + vaOpenForDelegation = ClosedForAll, + vaMetadataURL = emptyUrlText, + vaCommissionRates = + CommissionRates + { _transactionCommission = makeAmountFraction 0, + _finalizationCommission = makeAmountFraction 0, + _bakingCommission = makeAmountFraction 0 + } } - (bar, bs') <- bsoConfigureBaker bs ai conf - return (bar, (bs', ai)) + res <- bsoAddValidator bs ai conf + return ((,ai) <$> res) -- | Modify the staked amount to the given value. -modifyStakeTo :: Amount -> (PBS.PersistentBlockState PV, AccountIndex) -> ThisMonadConcrete PV (BakerConfigureResult, (PBS.PersistentBlockState PV, AccountIndex)) +modifyStakeTo :: + Amount -> + (PBS.PersistentBlockState PV, AccountIndex) -> + ThisMonadConcrete PV (Either ValidatorConfigureFailure ([BakerConfigureUpdateChange], (PBS.PersistentBlockState PV, AccountIndex))) modifyStakeTo a (bs, ai) = do let conf = - BakerConfigureUpdate - { bcuSlotTimestamp = 0, - bcuKeys = Nothing, - bcuCapital = Just a, - bcuRestakeEarnings = Nothing, - bcuOpenForDelegation = Nothing, - bcuMetadataURL = Nothing, - bcuTransactionFeeCommission = Nothing, - bcuBakingRewardCommission = Nothing, - bcuFinalizationRewardCommission = Nothing + ValidatorUpdate + { vuKeys = Nothing, + vuCapital = Just a, + vuRestakeEarnings = Nothing, + vuOpenForDelegation = Nothing, + vuMetadataURL = Nothing, + vuTransactionFeeCommission = Nothing, + vuBakingRewardCommission = Nothing, + vuFinalizationRewardCommission = Nothing } - (bsur, bs') <- bsoConfigureBaker bs ai conf - return (bsur, (bs', ai)) + res <- bsoUpdateValidator bs 0 ai conf + return (fmap (,ai) <$> res) -- | Increase the current threshold for baking. This uses some trickery to run a -- side monad that will be a MonadBlobStore that can retrieve the required @@ -191,19 +199,20 @@ testing1 :: ThisMonadConcrete PV () -- starting from an empty blockstate with the dummy parameters, try to register -- a baker with not enough stake. (MUST FAIL) testing1 = do - (res, _) <- + res <- createGS >>= createAccountWith (limitDelta `div` 2) >>= addBakerWith (limit `div` 2) case res of - BCStakeUnderThreshold -> return () - e -> error $ "Got (" ++ show e ++ ") but wanted BCStakeUnderThreshold" + Left VCFStakeUnderThreshold -> return () + Left e -> error $ "Got (" ++ show e ++ ") but wanted VCFStakeUnderThreshold" + Right _ -> error "Expected failure, but got success" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake and decrease the stake below the limit. (MUST FAIL) testing2'1 :: ThisMonadConcrete PV () testing2'1 = do - (res, _) <- + res <- createGS >>= createAccountWith limitDelta >>= addBakerWith limit @@ -214,17 +223,18 @@ testing2'1 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> modifyStakeTo (limit - 1) a - t -> return t + Right a -> modifyStakeTo (limit - 1) a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e case res of - BCStakeUnderThreshold -> return () - e -> error $ "Got (" ++ show e ++ ") but wanted BCStakeUnderThreshold" + Left VCFStakeUnderThreshold -> return () + Left e -> error $ "Got (" ++ show e ++ ") but wanted VCFStakeUnderThreshold" + Right _ -> error "Expected VCFStakeUnderThreshold, but got success" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake and decrease the stake above the limit. (MUST SUCCEED) testing2'2 :: ThisMonadConcrete PV () testing2'2 = do - (res, _) <- + res <- createGS >>= createAccountWith (limitDelta + 100) >>= addBakerWith (limit + 100) @@ -235,17 +245,18 @@ testing2'2 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> modifyStakeTo limit a - _ -> error "result of modifyStakeTo should be BCSuccess" + Right a -> modifyStakeTo limit a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e case res of - BCSuccess [BakerConfigureStakeReduced newStake] _ -> liftIO (assertEqual "new stake" limit newStake) - e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeReduced" + Right ([BakerConfigureStakeReduced newStake], _) -> liftIO (assertEqual "new stake" limit newStake) + Right (evts, _) -> error $ "Got " ++ show evts ++ " but wanted BakerConfigureStakeReduced" + Left e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeReduced" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake and increase the stake. (MUST SUCCEED) testing2'3 :: ThisMonadConcrete PV () testing2'3 = do - (res, _) <- + res <- createGS >>= createAccountWith (limitDelta + 100) >>= addBakerWith limit @@ -256,18 +267,19 @@ testing2'3 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> modifyStakeTo (limit + 100) a - _ -> error "result of modifyStakeTo should be BCSuccess" + Right a -> modifyStakeTo (limit + 100) a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e case res of - BCSuccess [BakerConfigureStakeIncreased newAmount] _ -> liftIO (assertEqual "new stake" (limit + 100) newAmount) - e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeIncreased" + Right ([BakerConfigureStakeIncreased newAmount], _) -> liftIO (assertEqual "new stake" (limit + 100) newAmount) + Right (evts, _) -> error $ "Got " ++ show evts ++ " but wanted BakerConfigureStakeIncreased" + Left e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeIncreased" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake, increase the limit and decrease the stake any amount (MUST -- FAIL) testing3'1 :: ThisMonadConcrete PV () testing3'1 = do - (res, _) <- + res <- createGS >>= createAccountWith limitDelta >>= addBakerWith limit @@ -278,13 +290,14 @@ testing3'1 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> increaseLimit (limit * 2) a - (_, bsAccIdx) -> return bsAccIdx + Right a -> increaseLimit (limit * 2) a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e ) >>= modifyStakeTo (limit - 1) case res of - BCStakeUnderThreshold -> return () - e -> error $ "Got (" ++ show e ++ ") but wanted BCStakeUnderThreshold" + Left VCFStakeUnderThreshold -> return () + Left e -> error $ "Got (" ++ show e ++ ") but wanted VCFStakeUnderThreshold" + Right _ -> error "Expected VCFStakeUnderThreshold, but got success" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake, increase the limit and increase the stake below limit @@ -292,7 +305,7 @@ testing3'1 = do -- Note, this is a departure from the behaviour prior to P4, where this would succeed. testing3'2 :: ThisMonadConcrete PV () testing3'2 = do - (res, _) <- + res <- createGS >>= createAccountWith limitDelta >>= addBakerWith limit @@ -303,20 +316,21 @@ testing3'2 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> increaseLimit (limit * 2) a - (_, bsAccIdx) -> return bsAccIdx + Right a -> increaseLimit (limit * 2) a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e ) >>= modifyStakeTo (limit + 1) case res of - BCStakeUnderThreshold -> return () - e -> error $ "Got (" ++ show e ++ ") but wanted BCStakeUnderThreshold" + Left VCFStakeUnderThreshold -> return () + Left e -> error $ "Got (" ++ show e ++ ") but wanted VCFStakeUnderThreshold" + Right _ -> error "Expected VCFStakeUnderThreshold, but got success" -- starting from an empty blockstate with the dummy parameters, register a baker -- with enough stake, increase the limit and increase the stake over limit (MUST -- SUCCEED) testing3'3 :: ThisMonadConcrete PV () testing3'3 = do - (res, _) <- + res <- createGS >>= createAccountWith limitDelta >>= addBakerWith limit @@ -327,13 +341,14 @@ testing3'3 = do -- \* the account is not a delegator; -- \* the account has sufficient balance to cover the stake, -- @(BCSuccess [], _)@ is returned, see `bsoConfigureBaker`. - (BCSuccess _ _, a) -> increaseLimit (limit * 2) a - _ -> error "result of increaseLimit should be BCSuccess" + Right a -> increaseLimit (limit * 2) a + Left e -> error $ "Unexpected failure when adding baker: " ++ show e ) >>= modifyStakeTo (limit * 2 + 1) case res of - BCSuccess [BakerConfigureStakeIncreased newStake] _ -> liftIO (assertEqual "new stake" (limit * 2 + 1) newStake) - e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeIncreased" + Right ([BakerConfigureStakeIncreased newStake], _) -> liftIO (assertEqual "new stake" (limit * 2 + 1) newStake) + Right (evts, _) -> error $ "Got " ++ show evts ++ " but wanted BakerConfigureStakeIncreased" + Left e -> error $ "Got (" ++ show e ++ ") but wanted BakerConfigureStakeIncreased" tests :: Spec tests = do diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index f291dd839..804439c58 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -11,6 +11,8 @@ import qualified GlobalStateTests.AccountsMigrationP6ToP7 (tests) import qualified GlobalStateTests.BlobStore (tests) import qualified GlobalStateTests.BlockHash (tests) import qualified GlobalStateTests.Cache (tests) +import qualified GlobalStateTests.ConfigureDelegator (tests) +import qualified GlobalStateTests.ConfigureValidator (tests) import qualified GlobalStateTests.CooldownProcessing (tests) import qualified GlobalStateTests.CooldownQueue (tests) import qualified GlobalStateTests.DifferenceMap (tests) @@ -59,3 +61,5 @@ main = atLevel $ \lvl -> hspec $ do GlobalStateTests.AccountList.tests GlobalStateTests.CooldownQueue.tests GlobalStateTests.CooldownProcessing.tests + GlobalStateTests.ConfigureValidator.tests lvl + GlobalStateTests.ConfigureDelegator.tests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs new file mode 100644 index 000000000..7d4dc452b --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs @@ -0,0 +1,1233 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Tests for the 'ConfigureBaker' transaction. +module SchedulerTests.ConfigureBaker (tests) where + +import Data.Bool.Singletons +import Lens.Micro.Platform + +import qualified Concordium.Cost as Cost +import qualified Concordium.Crypto.BlockSignature as Sig +import qualified Concordium.Crypto.BlsSignature as Bls +import qualified Concordium.Crypto.Proofs as Proofs +import qualified Concordium.Crypto.SignatureScheme as SigScheme +import qualified Concordium.Crypto.VRF as VRF +import Concordium.ID.Types as ID +import Concordium.Types.Accounts + +import Concordium.GlobalState.BakerInfo +import qualified Concordium.GlobalState.Basic.BlockState.Account as Transient +import qualified Concordium.GlobalState.BlockState as BS +import qualified Concordium.GlobalState.Persistent.Account as BS +import qualified Concordium.GlobalState.Persistent.BlobStore as Blob +import qualified Concordium.GlobalState.Persistent.BlockState as BS +import qualified Concordium.Scheduler.Runner as Runner +import Concordium.Scheduler.Types +import qualified Concordium.Scheduler.Types as Types + +import Concordium.GlobalState.CooldownQueue +import Concordium.GlobalState.DummyData +import Concordium.Scheduler.DummyData +import qualified Concordium.Types.DummyData as DummyData +import Concordium.Types.Option +import Data.Maybe +import qualified SchedulerTests.Helpers as Helpers +import Test.HUnit +import Test.Hspec + +-- | Deterministically generate a baker account from a seed. +makeTestBakerV1FromSeed :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + -- | The initial balance of the account. + Amount -> + -- | The initial staked amount of the account. + -- Must be less than or equal to the initial balance. + Amount -> + -- | The baker id of the account. + -- Must match the account index, which is the index of the account in the initial block state. + BakerId -> + -- | Seed used to generate account and baker keys. + Int -> + m (BS.PersistentAccount av) +makeTestBakerV1FromSeed amount stake bakerId seed = do + account <- Helpers.makeTestAccountFromSeed amount seed + let (fulBaker, _, _, _) = mkFullBaker seed bakerId + let bakerInfoEx = + BakerInfoExV1 + { _bieBakerInfo = fulBaker ^. theBakerInfo, + _bieBakerPoolInfo = poolInfo + } + BS.addAccountBakerV1 bakerInfoEx stake True account + where + poolInfo = + BakerPoolInfo + { _poolOpenStatus = OpenForAll, + _poolMetadataUrl = UrlText "Some URL", + _poolCommissionRates = + CommissionRates + { _finalizationCommission = makeAmountFraction 50_000, + _bakingCommission = makeAmountFraction 50_000, + _transactionCommission = makeAmountFraction 50_000 + } + } + +-- | Deterministically generate a delegator account from a seed. +makeTestDelegatorFromSeed :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + -- | The initial balance of the account. + Amount -> + -- | The delegating details added to the account. + AccountDelegation av -> + -- | Seed used to generate the account. + Int -> + m (BS.PersistentAccount av) +makeTestDelegatorFromSeed amount accountDelegation seed = do + account <- Helpers.makeTestAccountFromSeed amount seed + BS.addAccountDelegator accountDelegation account + +-- Accounts + +-- | Account of the baker 0. +baker0Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +baker0Account = makeTestBakerV1FromSeed 1_000_000_000_000 1_000_000_000_000 bakerId seed + where + bakerId = 0 + seed = 16 + +-- | Account of the delegator1. +delegator1Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +delegator1Account = makeTestDelegatorFromSeed 20_000_000_000_000 accountDelegation 17 + where + accountDelegation = + AccountDelegationV1 + { _delegationIdentity = 1, + _delegationStakedAmount = 19_000_000_000_000, -- leverage cap is set to 5 in createBlockState, so this puts it over the cap. + _delegationStakeEarnings = False, + _delegationTarget = DelegateToBaker 0, + _delegationPendingChange = NoChange + } + +-- | Account address of the delegator1. +delegator1Address :: AccountAddress +delegator1Address = Helpers.accountAddressFromSeed 17 + +-- | Account keys of the delegator1 account. +delegator1KP :: SigScheme.KeyPair +delegator1KP = Helpers.keyPairFromSeed 17 + +-- | Account of the baker 2. +baker2Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +baker2Account = makeTestBakerV1FromSeed balance stake bakerId seed + where + balance = 1_000_000_000_000 + stake = 1_000_000_000 + bakerId = 2 + seed = 18 + +-- | An account with no staking. +dummy3Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +dummy3Account = Helpers.makeTestAccountFromSeed 20_000_000_000_000 19 + +-- | Address of the dummy3 account. +dummy3Address :: AccountAddress +dummy3Address = Helpers.accountAddressFromSeed 19 + +-- | Keys of the dummy3 account. +dummy3KP :: SigScheme.KeyPair +dummy3KP = Helpers.keyPairFromSeed 19 + +-- | Account of the baker 4. +baker4Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +baker4Account = makeTestBakerV1FromSeed 20_000_000_000_000 500_000_000_000 bakerId seed + where + bakerId = 4 + seed = 20 + +-- | Account address of the delegator3. +baker4Address :: AccountAddress +baker4Address = Helpers.accountAddressFromSeed 20 + +-- | Account keys of the delegator3 account. +baker4KP :: SigScheme.KeyPair +baker4KP = Helpers.keyPairFromSeed 20 + +-- | Create initial block state with account +-- account index 0 is baker0 +-- account index 1 is delegator 1 (delegates to baker 0 with overdelegation) +-- account index 2 is baker 2 +-- account index 4 is baker 4 +initialBlockState2 :: + (IsProtocolVersion pv, PVSupportsDelegation pv) => + Helpers.PersistentBSM pv (BS.HashedPersistentBlockState pv) +initialBlockState2 = + Helpers.createTestBlockStateWithAccountsM + [ baker0Account, + delegator1Account, + baker2Account, + dummy3Account, + baker4Account + ] + +-- | Construct a (valid) 'BakerKeysWithProofs' from the given account address for keys generated +-- with the given seed. +makeBakerKeysWithProofs :: AccountAddress -> Int -> IO BakerKeysWithProofs +makeBakerKeysWithProofs senderAddress seed = do + bkwpProofElection <- fromJust <$> Proofs.proveDlog25519VRF challenge kpElection + bkwpProofSig <- fromJust <$> Proofs.proveDlog25519Block challenge kpSignature + bkwpProofAggregation <- Bls.proveKnowledgeOfSK challenge skAggregate + return BakerKeysWithProofs{..} + where + (fulBaker, skElection, skSignature, skAggregate) = mkFullBaker seed 0 + bkwpElectionVerifyKey = fulBaker ^. theBakerInfo . bakerElectionVerifyKey + bkwpSignatureVerifyKey = fulBaker ^. theBakerInfo . bakerSignatureVerifyKey + bkwpAggregationVerifyKey = fulBaker ^. theBakerInfo . bakerAggregationVerifyKey + kpElection = VRF.KeyPair skElection bkwpElectionVerifyKey + kpSignature = Sig.KeyPair skSignature bkwpSignatureVerifyKey + challenge = Types.configureBakerKeyChallenge senderAddress bkwpElectionVerifyKey bkwpSignatureVerifyKey bkwpAggregationVerifyKey + +-- | Transition delegator 1 to baker 1. +testDelegatorToBakerOk :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testDelegatorToBakerOk spv pvString = + specify (pvString ++ ": Delegator -> Baker (OK)") $ do + keysWithProofs <- makeBakerKeysWithProofs delegator1Address 1 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader delegator1Address 1 10_000, + keys = [(0, [(0, delegator1KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck (checkState keysWithProofs)) + transactions + () <- case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> Helpers.assertRejectWithReason AlreadyADelegator result + STrue -> Helpers.assertSuccessWithEvents (events keysWithProofs) result + doBlockStateAssertions + where + stakeAmount = 300_000_000_000 + events keysWithProofs = + [ DelegationRemoved{edrDelegatorId = 1, edrAccount = delegator1Address}, + BakerAdded + { ebaBakerId = 1, + ebaAccount = delegator1Address, + ebaSignKey = bkwpSignatureVerifyKey keysWithProofs, + ebaElectionKey = bkwpElectionVerifyKey keysWithProofs, + ebaAggregationKey = bkwpAggregationVerifyKey keysWithProofs, + ebaStake = stakeAmount, + ebaRestakeEarnings = False -- Inherited from the delegator + }, + BakerSetRestakeEarnings + { ebsreBakerId = 1, + ebsreAccount = delegator1Address, + ebsreRestakeEarnings = False + }, + BakerSetOpenStatus + { ebsosBakerId = 1, + ebsosAccount = delegator1Address, + ebsosOpenStatus = OpenForAll + }, + BakerSetMetadataURL + { ebsmuBakerId = 1, + ebsmuAccount = delegator1Address, + ebsmuMetadataURL = emptyUrlText + }, + BakerSetTransactionFeeCommission + { ebstfcBakerId = 1, + ebstfcAccount = delegator1Address, + ebstfcTransactionFeeCommission = makeAmountFraction 1_000 + }, + BakerSetBakingRewardCommission + { ebsbrcBakerId = 1, + ebsbrcAccount = delegator1Address, + ebsbrcBakingRewardCommission = makeAmountFraction 1_000 + }, + BakerSetFinalizationRewardCommission + { ebsfrcBakerId = 1, + ebsfrcAccount = delegator1Address, + ebsfrcFinalizationRewardCommission = makeAmountFraction 1_000 + } + ] + -- Transaction length is 438 bytes (378 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 438 1 + checkState :: + BakerKeysWithProofs -> + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState keysWithProofs result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 1 + initialAccount1 <- BS.toTransientAccount =<< delegator1Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + & updateStaking keysWithProofs + ) + updatedAccount1 + updatedBakerInfo :: BakerKeysWithProofs -> BakerInfoEx (AccountVersionFor pv) + updatedBakerInfo keysWithProofs = + BakerInfoExV1 + { _bieBakerInfo = + BakerInfo + { _bakerSignatureVerifyKey = bkwpSignatureVerifyKey keysWithProofs, + _bakerElectionVerifyKey = bkwpElectionVerifyKey keysWithProofs, + _bakerAggregationVerifyKey = bkwpAggregationVerifyKey keysWithProofs, + _bakerIdentity = 1 + }, + _bieBakerPoolInfo = + BakerPoolInfo + { _poolOpenStatus = OpenForAll, + _poolMetadataUrl = emptyUrlText, + _poolCommissionRates = + CommissionRates + { _finalizationCommission = makeAmountFraction 1_000, + _bakingCommission = makeAmountFraction 1_000, + _transactionCommission = makeAmountFraction 1_000 + } + } + } + updateStaking keysWithProofs = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> id + STrue -> + ( Transient.accountStaking + .~ AccountStakeBaker + ( AccountBaker + { _stakedAmount = stakeAmount, + _stakeEarnings = False, + _accountBakerInfo = updatedBakerInfo keysWithProofs, + _bakerPendingChange = NoChange + } + ) + ) + . ( Transient.accountStakeCooldown + .~ CTrue (emptyCooldowns{prePreCooldown = Present 18_700_000_000_000}) + ) + +-- | Transition delegator 1 to baker 1 using a duplicate aggregation key. +testDelegatorToBakerDuplicateKey :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testDelegatorToBakerDuplicateKey spv pvString = + specify (pvString ++ ": Delegator -> Baker (Duplicate Aggregation Key)") $ do + -- Reuse the same keys that baker 0 uses. + keysWithProofs <- makeBakerKeysWithProofs delegator1Address 16 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader delegator1Address 1 10_000, + keys = [(0, [(0, delegator1KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + () <- case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> Helpers.assertRejectWithReason AlreadyADelegator result + STrue -> + Helpers.assertRejectWithReason + (DuplicateAggregationKey (bkwpAggregationVerifyKey keysWithProofs)) + result + doBlockStateAssertions + where + stakeAmount = 300_000_000_000 + -- Transaction length is 438 bytes (378 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 438 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 1 + initialAccount1 <- BS.toTransientAccount =<< delegator1Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Transition delegator 1 to baker 1 using a duplicate aggregation key. +testDelegatorToBakerMissingParam :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testDelegatorToBakerMissingParam spv pvString = + specify (pvString ++ ": Delegator -> Baker (Missing Parameter)") $ do + -- Reuse the same keys that baker 0 uses. + keysWithProofs <- makeBakerKeysWithProofs delegator1Address 16 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Nothing, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader delegator1Address 1 10_000, + keys = [(0, [(0, delegator1KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + () <- case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> Helpers.assertRejectWithReason AlreadyADelegator result + STrue -> Helpers.assertRejectWithReason MissingBakerAddParameters result + doBlockStateAssertions + where + stakeAmount = 300_000_000_000 + -- Transaction length is 437 bytes (378 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 437 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 1 + initialAccount1 <- BS.toTransientAccount =<< delegator1Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test adding a baker successfully. +testAddBakerOk :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddBakerOk _spv pvString = + specify (pvString ++ ": AddBaker (OK)") $ do + keysWithProofs <- makeBakerKeysWithProofs dummy3Address 3 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader dummy3Address 1 transactionEnergy, + keys = [(0, [(0, dummy3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck (checkState keysWithProofs)) + transactions + Helpers.assertSuccessWithEvents (events keysWithProofs) result + doBlockStateAssertions + where + -- This stake is the maximal amount at which this will succeed. + stakeAmount = 20_000_000_000_000 - Helpers.energyToAmount transactionEnergy + events keysWithProofs = + [ BakerAdded + { ebaBakerId = 3, + ebaAccount = dummy3Address, + ebaSignKey = bkwpSignatureVerifyKey keysWithProofs, + ebaElectionKey = bkwpElectionVerifyKey keysWithProofs, + ebaAggregationKey = bkwpAggregationVerifyKey keysWithProofs, + ebaStake = stakeAmount, + ebaRestakeEarnings = True + }, + BakerSetRestakeEarnings + { ebsreBakerId = 3, + ebsreAccount = dummy3Address, + ebsreRestakeEarnings = True + }, + BakerSetOpenStatus + { ebsosBakerId = 3, + ebsosAccount = dummy3Address, + ebsosOpenStatus = OpenForAll + }, + BakerSetMetadataURL + { ebsmuBakerId = 3, + ebsmuAccount = dummy3Address, + ebsmuMetadataURL = emptyUrlText + }, + BakerSetTransactionFeeCommission + { ebstfcBakerId = 3, + ebstfcAccount = dummy3Address, + ebstfcTransactionFeeCommission = makeAmountFraction 1_000 + }, + BakerSetBakingRewardCommission + { ebsbrcBakerId = 3, + ebsbrcAccount = dummy3Address, + ebsbrcBakingRewardCommission = makeAmountFraction 1_000 + }, + BakerSetFinalizationRewardCommission + { ebsfrcBakerId = 3, + ebsfrcAccount = dummy3Address, + ebsfrcFinalizationRewardCommission = makeAmountFraction 1_000 + } + ] + -- Transaction length is 438 bytes (379 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 + checkState :: + BakerKeysWithProofs -> + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState keysWithProofs result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 3 + initialAccount1 <- BS.toTransientAccount =<< dummy3Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + & updateStaking keysWithProofs + ) + updatedAccount1 + updatedBakerInfo :: BakerKeysWithProofs -> BakerInfoEx (AccountVersionFor pv) + updatedBakerInfo keysWithProofs = + BakerInfoExV1 + { _bieBakerInfo = + BakerInfo + { _bakerSignatureVerifyKey = bkwpSignatureVerifyKey keysWithProofs, + _bakerElectionVerifyKey = bkwpElectionVerifyKey keysWithProofs, + _bakerAggregationVerifyKey = bkwpAggregationVerifyKey keysWithProofs, + _bakerIdentity = 3 + }, + _bieBakerPoolInfo = + BakerPoolInfo + { _poolOpenStatus = OpenForAll, + _poolMetadataUrl = emptyUrlText, + _poolCommissionRates = + CommissionRates + { _finalizationCommission = makeAmountFraction 1_000, + _bakingCommission = makeAmountFraction 1_000, + _transactionCommission = makeAmountFraction 1_000 + } + } + } + updateStaking keysWithProofs = + ( Transient.accountStaking + .~ AccountStakeBaker + ( AccountBaker + { _stakedAmount = stakeAmount, + _stakeEarnings = True, + _accountBakerInfo = updatedBakerInfo keysWithProofs, + _bakerPendingChange = NoChange + } + ) + ) + +-- | Test that adding a baker with insufficient balance is rejected. +testAddBakerInsufficientBalance :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddBakerInsufficientBalance _spv pvString = + specify (pvString ++ ": AddBaker (InsufficientBalance)") $ do + keysWithProofs <- makeBakerKeysWithProofs dummy3Address 3 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader dummy3Address 1 transactionEnergy, + keys = [(0, [(0, dummy3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason InsufficientBalanceForBakerStake result + doBlockStateAssertions + where + -- This stake is the minimal amount at which this will fail. + stakeAmount = 20_000_000_000_000 - Helpers.energyToAmount transactionEnergy + 1 + -- Transaction length is 438 bytes (379 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 3 + initialAccount1 <- BS.toTransientAccount =<< dummy3Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test that adding a baker with incomplete parameters is rejected. +testAddBakerMissingParam :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddBakerMissingParam _spv pvString = + specify (pvString ++ ": AddBaker (Missing Parameter)") $ do + keysWithProofs <- makeBakerKeysWithProofs dummy3Address 3 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Nothing, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader dummy3Address 1 transactionEnergy, + keys = [(0, [(0, dummy3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason MissingBakerAddParameters result + doBlockStateAssertions + where + -- This stake is the minimal amount at which this will fail. + stakeAmount = 20_000_000_000_000 - Helpers.energyToAmount transactionEnergy + 1 + -- Transaction length is 437 bytes (377 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 437 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 3 + initialAccount1 <- BS.toTransientAccount =<< dummy3Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test that adding a baker with invalid proofs is rejected. +testAddBakerInvalidProofs :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddBakerInvalidProofs _spv pvString = + specify (pvString ++ ": AddBaker (InvalidProofs)") $ do + keysWithProofsOk <- makeBakerKeysWithProofs dummy3Address 3 + let keysWithProofs = keysWithProofsOk{bkwpSignatureVerifyKey = Sig.verifyKey $ DummyData.bakerSignKey 0} + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader dummy3Address 1 transactionEnergy, + keys = [(0, [(0, dummy3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason InvalidProof result + doBlockStateAssertions + where + stakeAmount = 20_000_000_000_000 - Helpers.energyToAmount transactionEnergy + -- Transaction length is 438 bytes (379 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 3 + initialAccount1 <- BS.toTransientAccount =<< dummy3Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test updating an existing baker successfully. +testUpdateBakerOk :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerOk _spv pvString = + specify (pvString ++ ": UpdateBaker (OK)") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Nothing, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Nothing, + cbFinalizationRewardCommission = Nothing + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertSuccessWithEvents events result + doBlockStateAssertions + where + stakeAmount = 10_000_000_000_000 - Helpers.energyToAmount transactionEnergy + events = + [ BakerSetRestakeEarnings + { ebsreBakerId = 4, + ebsreAccount = baker4Address, + ebsreRestakeEarnings = True + }, + BakerSetOpenStatus + { ebsosBakerId = 4, + ebsosAccount = baker4Address, + ebsosOpenStatus = OpenForAll + }, + BakerSetMetadataURL + { ebsmuBakerId = 4, + ebsmuAccount = baker4Address, + ebsmuMetadataURL = emptyUrlText + }, + BakerSetTransactionFeeCommission + { ebstfcBakerId = 4, + ebstfcAccount = baker4Address, + ebstfcTransactionFeeCommission = makeAmountFraction 1_000 + }, + BakerStakeIncreased + { ebsiBakerId = 4, + ebsiAccount = baker4Address, + ebsiNewStake = stakeAmount + } + ] + -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + & updateStaking + ) + updatedAccount1 + updateStaking = + ( Transient.accountStaking . accountBaker + %~ (stakedAmount .~ stakeAmount) + . (stakeEarnings .~ True) + . ( accountBakerInfo . bieBakerPoolInfo + %~ (poolCommissionRates . transactionCommission .~ makeAmountFraction 1_000) + . (poolMetadataUrl .~ emptyUrlText) + ) + ) + accountBaker f (AccountStakeBaker b) = AccountStakeBaker <$> f b + accountBaker _ x = pure x + +-- | Test that configuring a baker with capital this is above its balance is rejected. +testUpdateBakerInsufficientBalance :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerInsufficientBalance _spv pvString = + specify (pvString ++ ": UpdateBaker (Insufficient Balance)") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Nothing, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Nothing, + cbFinalizationRewardCommission = Nothing + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason InsufficientBalanceForBakerStake result + doBlockStateAssertions + where + stakeAmount = 100_000_000_000_000 - Helpers.energyToAmount transactionEnergy + -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test that configuring a baker with capital this is above its balance is rejected. +testUpdateBakerLowStake :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerLowStake _spv pvString = + specify (pvString ++ ": UpdateBaker (StakeUnderThreshold)") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Just True, + cbOpenForDelegation = Just OpenForAll, + cbKeysWithProofs = Nothing, + cbMetadataURL = Just emptyUrlText, + cbTransactionFeeCommission = Just (makeAmountFraction 1_000), + cbBakingRewardCommission = Nothing, + cbFinalizationRewardCommission = Nothing + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason StakeUnderMinimumThresholdForBaking result + doBlockStateAssertions + where + stakeAmount = 100_000 + -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +-- | Test that configuring a baker with invalid proofs is rejected. +testUpdateBakerInvalidProofs :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerInvalidProofs _spv pvString = + specify (pvString ++ ": UpdateBaker (InvalidProofs)") $ do + -- Generate keys with challenge for a different account. + keysWithProofs <- makeBakerKeysWithProofs dummy3Address 912 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Nothing, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Nothing, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Nothing, + cbTransactionFeeCommission = Nothing, + cbBakingRewardCommission = Nothing, + cbFinalizationRewardCommission = Nothing + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason InvalidProof result + doBlockStateAssertions + where + -- Transaction length is 415 bytes (355 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 415 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + ) + updatedAccount1 + +testUpdateBakerRemoveOk :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerRemoveOk spv pvString = + specify (pvString ++ ": RemoveBaker (OK)") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just 0, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Nothing, + cbKeysWithProofs = Nothing, + cbMetadataURL = Nothing, + cbTransactionFeeCommission = Nothing, + cbBakingRewardCommission = Nothing, + cbFinalizationRewardCommission = Nothing + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertSuccessWithEvents events result + doBlockStateAssertions + where + events = + [ BakerRemoved + { ebrBakerId = 4, + ebrAccount = baker4Address + } + ] + -- Transaction length is 71 bytes (11 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 71 1 + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + & updateStaking + ) + updatedAccount1 + updateStaking = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> + Transient.accountStaking . accountBaker . bakerPendingChange + .~ RemoveStake (PendingChangeEffectiveV1 86400000) + STrue -> + (Transient.accountStaking .~ AccountStakeNone) + . (Transient.accountStakeCooldown . unconditionally .~ emptyCooldowns{prePreCooldown = Present 500_000_000_000}) + accountBaker f (AccountStakeBaker b) = AccountStakeBaker <$> f b + accountBaker _ x = pure x + +testUpdateBakerReduceStakeOk :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testUpdateBakerReduceStakeOk spv pvString = + specify (pvString ++ ": UpdateBaker: ReduceStake (OK)") $ do + keysWithProofs <- makeBakerKeysWithProofs baker4Address 4000 + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureBaker + { cbCapital = Just stakeAmount, + cbRestakeEarnings = Nothing, + cbOpenForDelegation = Nothing, + cbKeysWithProofs = Just keysWithProofs, + cbMetadataURL = Nothing, + cbTransactionFeeCommission = Nothing, + cbBakingRewardCommission = Just (makeAmountFraction 1_000), + cbFinalizationRewardCommission = Just (makeAmountFraction 1_000) + }, + metadata = makeDummyHeader baker4Address 1 transactionEnergy, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck (checkState keysWithProofs)) + transactions + Helpers.assertSuccessWithEvents (events keysWithProofs) result + doBlockStateAssertions + where + stakeAmount = 300_000_000_000 -- Minimum stake amount + events keysWithProofs = + [ BakerKeysUpdated + { ebkuBakerId = 4, + ebkuAccount = baker4Address, + ebkuSignKey = bkwpSignatureVerifyKey keysWithProofs, + ebkuElectionKey = bkwpElectionVerifyKey keysWithProofs, + ebkuAggregationKey = bkwpAggregationVerifyKey keysWithProofs + }, + BakerSetBakingRewardCommission + { ebsbrcBakerId = 4, + ebsbrcAccount = baker4Address, + ebsbrcBakingRewardCommission = makeAmountFraction 1_000 + }, + BakerSetFinalizationRewardCommission + { ebsfrcBakerId = 4, + ebsfrcAccount = baker4Address, + ebsfrcFinalizationRewardCommission = makeAmountFraction 1_000 + }, + BakerStakeDecreased + { ebsiBakerId = 4, + ebsiAccount = baker4Address, + ebsiNewStake = stakeAmount + } + ] + -- Transaction length is 431 bytes (371 bytes for the transaction and 60 bytes for the header). + transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 431 1 + checkState :: + BakerKeysWithProofs -> + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState keysWithProofs result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedAccount1 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialAccount1 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Expected account update" + ( initialAccount1 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount transactionEnergy + & updateStaking keysWithProofs + ) + updatedAccount1 + updateStaking keysWithProofs = + ( case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> + Transient.accountStaking . accountBaker + %~ ( bakerPendingChange .~ ReduceStake stakeAmount (PendingChangeEffectiveV1 86400000) + ) + STrue -> + (Transient.accountStakeCooldown . unconditionally .~ emptyCooldowns{prePreCooldown = Present 200_000_000_000}) + . (Transient.accountStaking . accountBaker . stakedAmount .~ stakeAmount) + ) + . ( Transient.accountStaking . accountBaker . accountBakerInfo + %~ (poolCommissionRates . bakingCommission .~ makeAmountFraction 1_000) + . (poolCommissionRates . finalizationCommission .~ makeAmountFraction 1_000) + . (bakerElectionVerifyKey .~ bkwpElectionVerifyKey keysWithProofs) + . (bakerSignatureVerifyKey .~ bkwpSignatureVerifyKey keysWithProofs) + . (bakerAggregationVerifyKey .~ bkwpAggregationVerifyKey keysWithProofs) + ) + accountBaker f (AccountStakeBaker b) = AccountStakeBaker <$> f b + accountBaker _ x = pure x + +tests :: Spec +tests = + describe "ConfigureBaker transactions" $ + sequence_ $ + Helpers.forEveryProtocolVersion testCases + where + testCases :: forall pv. (IsProtocolVersion pv) => SProtocolVersion pv -> String -> Spec + testCases spv pvString = + case delegationSupport @(AccountVersionFor pv) of + SAVDelegationNotSupported -> return () + SAVDelegationSupported -> do + testDelegatorToBakerOk spv pvString + testDelegatorToBakerDuplicateKey spv pvString + testDelegatorToBakerMissingParam spv pvString + testAddBakerOk spv pvString + testAddBakerInsufficientBalance spv pvString + testAddBakerMissingParam spv pvString + testAddBakerInvalidProofs spv pvString + testUpdateBakerOk spv pvString + testUpdateBakerInsufficientBalance spv pvString + testUpdateBakerLowStake spv pvString + testUpdateBakerInvalidProofs spv pvString + testUpdateBakerRemoveOk spv pvString + testUpdateBakerReduceStakeOk spv pvString diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs index 4ceda5162..9f2d88b22 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs @@ -8,18 +8,19 @@ -- | Test that reducing delegation and removing delegators always works, regardless -- of whether the new stake would violate any of the cap bounds. --- --- This currently only tests with the basic state implementation which is not --- ideal. The test should be expanded to also use the persistent state implementation. module SchedulerTests.Delegation (tests) where +import Data.Bool.Singletons import Lens.Micro.Platform +import qualified Concordium.Cost as Cost import qualified Concordium.Crypto.SignatureScheme as SigScheme import Concordium.ID.Types as ID import Concordium.Types.Accounts import Concordium.GlobalState.BakerInfo +import qualified Concordium.GlobalState.Basic.BlockState.Account as Transient +import qualified Concordium.GlobalState.BlockState as BS import qualified Concordium.GlobalState.Persistent.Account as BS import qualified Concordium.GlobalState.Persistent.BlobStore as Blob import qualified Concordium.GlobalState.Persistent.BlockState as BS @@ -28,8 +29,12 @@ import qualified Concordium.Scheduler.Runner as Runner import Concordium.Scheduler.Types import qualified Concordium.Scheduler.Types as Types +import Concordium.GlobalState.CooldownQueue import Concordium.GlobalState.DummyData import Concordium.Scheduler.DummyData +import Concordium.Types.Option +import Control.Monad +import Data.Maybe import qualified SchedulerTests.Helpers as Helpers import Test.HUnit import Test.Hspec @@ -152,6 +157,11 @@ delegator3Address = Helpers.accountAddressFromSeed 19 delegator3KP :: SigScheme.KeyPair delegator3KP = Helpers.keyPairFromSeed 19 +dummy3Account :: + (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => + m (BS.PersistentAccount av) +dummy3Account = Helpers.makeTestAccountFromSeed 20_000_000 19 + -- | Account of the baker 4. baker4Account :: (IsAccountVersion av, Blob.MonadBlobStore m, AVSupportsDelegation av) => @@ -161,6 +171,14 @@ baker4Account = makeTestBakerV1FromSeed 1_000_000 1_000 bakerId seed bakerId = 4 seed = 20 +-- | Account address of the delegator3. +baker4Address :: AccountAddress +baker4Address = Helpers.accountAddressFromSeed 20 + +-- | Account keys of the delegator3 account. +baker4KP :: SigScheme.KeyPair +baker4KP = Helpers.keyPairFromSeed 20 + -- | Create initial block state with account -- account index 0 is baker0 -- account index 1 is delegator 1 (delegates to baker 0 with overdelegation) @@ -179,14 +197,31 @@ initialBlockState = baker4Account ] +-- | Create initial block state with account +-- account index 0 is baker0 +-- account index 1 is delegator 1 (delegates to baker 0 with overdelegation) +-- account index 2 is baker 2 +-- account index 4 is baker 4 +initialBlockState2 :: + (IsProtocolVersion pv, PVSupportsDelegation pv) => + Helpers.PersistentBSM pv (BS.HashedPersistentBlockState pv) +initialBlockState2 = + Helpers.createTestBlockStateWithAccountsM + [ baker0Account, + delegator1Account, + baker2Account, + dummy3Account, + baker4Account + ] + -- | Test removing a delegator even if the stake is over the threshold. -testCase1 :: +testRemoveDelegatorWithStakeOverThreshold :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase1 _ pvString = +testRemoveDelegatorWithStakeOverThreshold _ pvString = specify (pvString ++ ": Remove delegation") $ do let transactions = [ Runner.TJSON @@ -226,13 +261,13 @@ testCase1 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Test reducing delegator stake in such a way that it stays above the cap threshold. -testCase2 :: +testReduceDelegatorStakeStillAboveCapThreshold :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase2 _ pvString = +testReduceDelegatorStakeStillAboveCapThreshold _ pvString = specify (pvString ++ ": Reduce delegation stake with overstaking") $ do let transactions = [ Runner.TJSON @@ -263,13 +298,13 @@ testCase2 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Test transaction rejects if increasing stake above the threshold of the pool -testCase3 :: +testTransactionRejectsIfStakeIncreasedOverThreshold :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase3 _ pvString = +testTransactionRejectsIfStakeIncreasedOverThreshold _ pvString = specify (pvString ++ ": Increase stake with overstaking") $ do let transactions = [ Runner.TJSON @@ -301,13 +336,13 @@ testCase3 _ pvString = -- | Test reducing delegator stake **and changing target** such that the new stake is above the cap -- for the new target. -testCase4 :: +testReducingStakeAndTargetNewStakeOverCap :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase4 _ pvString = +testReducingStakeAndTargetNewStakeOverCap _ pvString = specify (pvString ++ ": Reduce stake and change target 1") $ do let transactions = [ Runner.TJSON @@ -338,14 +373,16 @@ testCase4 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Test changing the target and decreasing stake such that the new stake is acceptable for the new target. --- This still fails because the change of target is only effected after the cooldown period. -testCase5 :: +-- This still fails before P7 because the change of stake is only effective after the cooldown period, +-- so changing the target results in overdelegation to the new target. From P7, the stake is +-- reduced immediately, so the transaction should succeed. +testChangingTargetAndReducingStake :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase5 _ pvString = +testChangingTargetAndReducingStake _ pvString = specify (pvString ++ ": Reduce stake and change target 2") $ do let transactions = [ Runner.TJSON @@ -365,7 +402,15 @@ testCase5 _ pvString = (initialBlockState @pv) (Helpers.checkReloadCheck checkState) transactions - Helpers.assertRejectWithReason StakeOverMaximumThresholdForPool result + () <- case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of + SFalse -> + Helpers.assertRejectWithReason StakeOverMaximumThresholdForPool result + STrue -> + Helpers.assertSuccessWithEvents + [ DelegationSetDelegationTarget 1 delegator1Address (DelegateToBaker 2), + DelegationStakeDecreased 1 delegator1Address 1 + ] + result doBlockStateAssertions where checkState :: @@ -376,13 +421,13 @@ testCase5 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Increase stake successfully. -testCase6 :: +testIncreaseStake :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase6 _ pvString = +testIncreaseStake _ pvString = specify (pvString ++ ": Increase stake successfully.") $ do let transactions = [ Runner.TJSON @@ -413,13 +458,13 @@ testCase6 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Increase stake and change target successfully. -testCase7 :: +testIncreaseStakeAndTarget :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase7 _ pvString = +testIncreaseStakeAndTarget _ pvString = specify (pvString ++ ": Increase stake and change target successfully.") $ do let transactions = [ Runner.TJSON @@ -454,13 +499,13 @@ testCase7 _ pvString = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) -- | Increase stake and change target rejects with reason: maximum threshold for pool. -testCase8 :: +testIncreaseStakeAndChangeTargetReject :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase8 _ pvString = +testIncreaseStakeAndChangeTargetReject _ pvString = specify (pvString ++ ": Increase stake and change target so that results is overdelegation.") $ do let transactions = [ Runner.TJSON @@ -490,14 +535,14 @@ testCase8 _ pvString = checkState result blockState = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) --- | Increase stake and change target rejects with reason: maximum threshold for pool. -testCase9 :: +-- | Change target to overdelegated pool +testChangeTargetToOverdelegatedPool :: forall pv. (IsProtocolVersion pv, PVSupportsDelegation pv) => SProtocolVersion pv -> String -> Spec -testCase9 _ pvString = +testChangeTargetToOverdelegatedPool _ pvString = specify (pvString ++ ": Change target to overdelegated pool.") $ do let transactions = [ Runner.TJSON @@ -527,6 +572,348 @@ testCase9 _ pvString = checkState result blockState = Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) +-- | Add delegator successfully. +testAddDelegator :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddDelegator _ pvString = + specify (pvString ++ ": Add delegator successfully.") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 1_000, + cdRestakeEarnings = Just False, + cdDelegationTarget = Just (DelegateToBaker 2) + }, + metadata = makeDummyHeader delegator3Address 1 1_000, + keys = [(0, [(0, delegator3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertSuccessWithEvents events result + doBlockStateAssertions + where + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = + Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + events = + [ DelegationAdded 3 delegator3Address, + DelegationSetDelegationTarget 3 delegator3Address (DelegateToBaker 2), + DelegationSetRestakeEarnings 3 delegator3Address False, + DelegationStakeIncreased 3 delegator3Address 1_000 + ] + +-- | Add delegator with 0 stake should get rejected. +testDelegatorWithZeroStake :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testDelegatorWithZeroStake _ pvString = + specify (pvString ++ ": Add delegator with 0 stake should get rejected.") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 0, + cdRestakeEarnings = Just False, + cdDelegationTarget = Just (DelegateToBaker 2) + }, + metadata = makeDummyHeader delegator3Address 1 1_000, + keys = [(0, [(0, delegator3KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + Helpers.assertRejectWithReason InsufficientDelegationStake result + doBlockStateAssertions + where + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = + Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + +-- | Add delegator when already baker. Should get rejected in protocols <= P6 and accepted from P7. +testAddDelegatorWhenAlreadyBaker :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddDelegatorWhenAlreadyBaker spv pvString = + specify (pvString ++ ": Add delegator when already baker.") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 1_000, + cdRestakeEarnings = Just False, + cdDelegationTarget = Just (DelegateToBaker 2) + }, + metadata = makeDummyHeader baker4Address 1 1_000, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + let successOrReject :: Assertion + successOrReject = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> Helpers.assertRejectWithReason (AlreadyABaker 4) result + STrue -> Helpers.assertSuccessWithEvents events result + successOrReject + doBlockStateAssertions + where + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = + Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + events = + [ BakerRemoved 4 baker4Address, + DelegationAdded 4 baker4Address, + DelegationSetDelegationTarget 4 baker4Address (DelegateToBaker 2), + DelegationSetRestakeEarnings 4 baker4Address False, + DelegationStakeIncreased 4 baker4Address 1_000 + ] + +-- | Add delegator with 0 stake when already a baker should get rejected with +-- `AlreadyABaker` in protocols <= P6 and `InsufficientDelegationStake` from P7. +testAddDelegatorWithZeroStakeWhenAlreadyBaker :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testAddDelegatorWithZeroStakeWhenAlreadyBaker spv pvString = + specify (pvString ++ ": Add delegator with 0 stake when already baker should get rejected.") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 0, + cdRestakeEarnings = Just False, + cdDelegationTarget = Just (DelegateToBaker 2) + }, + metadata = makeDummyHeader baker4Address 1 1_000, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + let reason = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> AlreadyABaker 4 + STrue -> InsufficientDelegationStake + Helpers.assertRejectWithReason reason result + doBlockStateAssertions + where + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedBaker4 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialBaker4 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Baker account should not have changed except nonce and balance" + ( initialBaker4 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount (Cost.configureDelegationCost + Cost.baseCost 81 1) + ) + updatedBaker4 + +-- | Reduce stake while in cooldown. +testReduceStakeWhileInCooldown :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testReduceStakeWhileInCooldown spv pvString = + specify (pvString ++ ": Reduce stake while in cooldown.") $ do + let transactionsAndAssertions :: [Helpers.TransactionAndAssertion pv] + transactionsAndAssertions = + [ Helpers.TransactionAndAssertion + { taaTransaction = + Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 999, + cdRestakeEarnings = Nothing, + cdDelegationTarget = Nothing + }, + metadata = makeDummyHeader delegator3Address 1 1_000, + keys = [(0, [(0, delegator3KP)])] + }, + taaAssertion = \result _ -> do + return $ do + Helpers.assertSuccessWithEvents + [DelegationStakeDecreased 3 delegator3Address 999] + result + }, + Helpers.TransactionAndAssertion + { taaTransaction = + Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 995, + cdRestakeEarnings = Nothing, + cdDelegationTarget = Nothing + }, + metadata = makeDummyHeader delegator3Address 2 1_000, + keys = [(0, [(0, delegator3KP)])] + }, + taaAssertion = assertPrePreCooldown 5 (DelegationStakeDecreased 3 delegator3Address 995) + }, + Helpers.TransactionAndAssertion + { taaTransaction = + Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 998, + cdRestakeEarnings = Nothing, + cdDelegationTarget = Nothing + }, + metadata = makeDummyHeader delegator3Address 3 1_000, + keys = [(0, [(0, delegator3KP)])] + }, + taaAssertion = assertPrePreCooldown 2 (DelegationStakeIncreased 3 delegator3Address 998) + }, + Helpers.TransactionAndAssertion + { taaTransaction = + Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 1000, + cdRestakeEarnings = Nothing, + cdDelegationTarget = Nothing + }, + metadata = makeDummyHeader delegator3Address 4 1_000, + keys = [(0, [(0, delegator3KP)])] + }, + taaAssertion = assertNoCooldown (DelegationStakeIncreased 3 delegator3Address 1000) + } + ] + Helpers.runSchedulerTestAssertIntermediateStates + @pv + Helpers.defaultTestConfig + initialBlockState + transactionsAndAssertions + where + assertPrePreCooldown :: Amount -> Event -> Helpers.TransactionAssertion pv + assertPrePreCooldown expAmt event result pbs = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + STrue -> do + maybeAccount <- BS.bsoGetAccount pbs delegator3Address + case maybeAccount of + Nothing -> return $ assertFailure $ "Account with address '" ++ show delegator3Address ++ "' not found" + Just (_, account) -> do + maybeCooldowns <- BS.accountCooldowns account + let toAssert = case maybeCooldowns of + Nothing -> assertFailure "Account should have been in pre-pre-cooldown" + Just cd -> case prePreCooldown cd of + Absent -> assertFailure "Account should have been in pre-pre cooldown" + Present amt -> assertEqual "Amount in pre-pre-cooldown should be correct" expAmt amt + return $ do + toAssert + Helpers.assertSuccessWithEvents [event] result + SFalse -> + return $ Helpers.assertRejectWithReason DelegatorInCooldown result + assertNoCooldown :: Event -> Helpers.TransactionAssertion pv + assertNoCooldown event result pbs = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + STrue -> do + maybeAccount <- BS.bsoGetAccount pbs delegator3Address + case maybeAccount of + Nothing -> return $ assertFailure $ "Account with address '" ++ show delegator3Address ++ "' not found" + Just (_, account) -> do + maybeCooldowns <- BS.accountCooldowns account + return $ do + when (isJust maybeCooldowns) $ assertFailure "Account should have no cooldowns" + Helpers.assertSuccessWithEvents [event] result + SFalse -> + return $ Helpers.assertRejectWithReason DelegatorInCooldown result + +-- | Change baker to delegate to itself should get rejected with +-- `AlreadyABaker` in protocols <= P6 and `DelegationTargetNotABaker` from P7. +testDelegateToSelf :: + forall pv. + (IsProtocolVersion pv, PVSupportsDelegation pv) => + SProtocolVersion pv -> + String -> + Spec +testDelegateToSelf spv pvString = + specify (pvString ++ ": Change baker to delegate to itself.") $ do + let transactions = + [ Runner.TJSON + { payload = + Runner.ConfigureDelegation + { cdCapital = Just 1000, + cdRestakeEarnings = Just False, + cdDelegationTarget = Just (DelegateToBaker 4) + }, + metadata = makeDummyHeader baker4Address 1 1_000, + keys = [(0, [(0, baker4KP)])] + } + ] + (result, doBlockStateAssertions) <- + Helpers.runSchedulerTestTransactionJson + Helpers.defaultTestConfig + (initialBlockState2 @pv) + (Helpers.checkReloadCheck checkState) + transactions + let reason = case sSupportsFlexibleCooldown (sAccountVersionFor spv) of + SFalse -> AlreadyABaker 4 + STrue -> DelegationTargetNotABaker 4 + Helpers.assertRejectWithReason reason result + doBlockStateAssertions + where + checkState :: + Helpers.SchedulerResult -> + BS.PersistentBlockState pv -> + Helpers.PersistentBSM pv Assertion + checkState result blockState = do + invariants <- Helpers.assertBlockStateInvariantsH blockState (Helpers.srExecutionCosts result) + updatedBaker4 <- BS.toTransientAccount . fromJust =<< BS.bsoGetAccountByIndex blockState 4 + initialBaker4 <- BS.toTransientAccount =<< baker4Account @(AccountVersionFor pv) + return $ do + invariants + assertEqual + "Baker account should not have changed except nonce and balance" + ( initialBaker4 + & Transient.accountNonce .~ 2 + & Transient.accountAmount -~ Helpers.energyToAmount (Cost.configureDelegationCost + Cost.baseCost 81 1) + ) + updatedBaker4 + tests :: Spec tests = describe "Delegate in different scenarios" $ @@ -537,15 +924,19 @@ tests = testCases spv pvString = case delegationSupport @(AccountVersionFor pv) of SAVDelegationNotSupported -> return () - SAVDelegationSupported -> - -- FIXME: re-enable when P7 cases are implemented (#1145) - (if demoteProtocolVersion spv == P7 then xdescribe "P7 cases unimplemented" else id) $ do - testCase1 spv pvString - testCase2 spv pvString - testCase3 spv pvString - testCase4 spv pvString - testCase5 spv pvString - testCase6 spv pvString - testCase7 spv pvString - testCase8 spv pvString - testCase9 spv pvString + SAVDelegationSupported -> do + testRemoveDelegatorWithStakeOverThreshold spv pvString + testReduceDelegatorStakeStillAboveCapThreshold spv pvString + testTransactionRejectsIfStakeIncreasedOverThreshold spv pvString + testReducingStakeAndTargetNewStakeOverCap spv pvString + testChangingTargetAndReducingStake spv pvString + testIncreaseStake spv pvString + testIncreaseStakeAndTarget spv pvString + testIncreaseStakeAndChangeTargetReject spv pvString + testChangeTargetToOverdelegatedPool spv pvString + testAddDelegator spv pvString + testDelegatorWithZeroStake spv pvString + testAddDelegatorWhenAlreadyBaker spv pvString + testAddDelegatorWithZeroStakeWhenAlreadyBaker spv pvString + testReduceStakeWhileInCooldown spv pvString + testDelegateToSelf spv pvString diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 1886d111d..e510c0a6b 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -137,6 +137,11 @@ forEveryProtocolVersion check = check Types.SP7 "P7" ] +-- | Convert an energy value to an amount, based on the exchange rates used in +-- 'DummyData.dummyChainParameters'. +energyToAmount :: Types.Energy -> Types.Amount +energyToAmount = Types.computeCost (Types.makeExchangeRates 0.000_1 1_000_000 ^. Types.energyRate) + -- | Construct a test block state containing the provided accounts. createTestBlockStateWithAccounts :: forall pv. diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index db6979f1d..55cedd0ea 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -4,6 +4,7 @@ import qualified SchedulerTests.AccountTransactionSpecs (tests) import qualified SchedulerTests.BakerTransactions (tests) import qualified SchedulerTests.BlockEnergyLimitSpec (tests) import qualified SchedulerTests.ChainMetatest (tests) +import qualified SchedulerTests.ConfigureBaker (tests) import qualified SchedulerTests.Delegation (tests) import qualified SchedulerTests.EncryptedTransfersTest (tests) import qualified SchedulerTests.FibonacciSelfMessageTest (tests) @@ -103,6 +104,7 @@ main = hspec $ do SchedulerTests.SmartContracts.V1.QueriesPersistent.tests SchedulerTests.Payday.tests SchedulerTests.Delegation.tests + SchedulerTests.ConfigureBaker.tests SchedulerTests.SmartContracts.V1.P6WasmFeatures.tests SchedulerTests.SmartContracts.V1.CustomSectionSize.tests SchedulerTests.SmartContracts.V1.AccountSignatureChecks.tests diff --git a/concordium-node/Cargo.lock b/concordium-node/Cargo.lock index 8cb19f6e6..bdefe0cf9 100644 --- a/concordium-node/Cargo.lock +++ b/concordium-node/Cargo.lock @@ -670,7 +670,7 @@ dependencies = [ [[package]] name = "concordium-contracts-common" -version = "9.1.0" +version = "9.2.0" dependencies = [ "base64 0.21.7", "bs58", @@ -699,7 +699,7 @@ dependencies = [ [[package]] name = "concordium-smart-contract-engine" -version = "5.0.0" +version = "6.0.0" dependencies = [ "anyhow", "byteorder", @@ -721,7 +721,7 @@ dependencies = [ [[package]] name = "concordium-wasm" -version = "4.0.0" +version = "5.0.0" dependencies = [ "anyhow", "concordium-contracts-common", @@ -732,7 +732,7 @@ dependencies = [ [[package]] name = "concordium_base" -version = "5.0.0" +version = "6.0.0" dependencies = [ "aes", "anyhow", @@ -787,7 +787,7 @@ dependencies = [ [[package]] name = "concordium_node" -version = "6.3.1" +version = "7.0.3" dependencies = [ "anyhow", "app_dirs2", diff --git a/concordium-node/Cargo.toml b/concordium-node/Cargo.toml index 7d67e6233..657d5753c 100644 --- a/concordium-node/Cargo.toml +++ b/concordium-node/Cargo.toml @@ -1,6 +1,6 @@ [package] name = "concordium_node" -version = "6.3.1" # must be kept in sync with 'is_compatible_version' in 'src/configuration.rs' +version = "7.0.3" # must be kept in sync with 'is_compatible_version' in 'src/configuration.rs' description = "Concordium Node" authors = ["Concordium "] exclude = [".gitignore", ".gitlab-ci.yml", "test/**/*","**/**/.gitignore","**/**/.gitlab-ci.yml"] diff --git a/concordium-node/src/consensus_ffi/ffi.rs b/concordium-node/src/consensus_ffi/ffi.rs index e6ee2494b..1faddf7de 100644 --- a/concordium-node/src/consensus_ffi/ffi.rs +++ b/concordium-node/src/consensus_ffi/ffi.rs @@ -1958,7 +1958,8 @@ impl ConsensusContainer { ( ConsensusFfiResponse::try_from(result) - .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)), + .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)) + .check_consistent(), callback, ) } @@ -1971,14 +1972,17 @@ impl ConsensusContainer { let result = unsafe { executeBlock(consensus, execute_block_callback) }; ConsensusFfiResponse::try_from(result) .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)) + .check_consistent() } pub fn send_finalization(&self, genesis_index: u32, msg: &[u8]) -> ConsensusFfiResponse { wrap_send_data_to_c!(self, genesis_index, msg, receiveFinalizationMessage) + .check_consistent() } pub fn send_finalization_record(&self, genesis_index: u32, rec: &[u8]) -> ConsensusFfiResponse { wrap_send_data_to_c!(self, genesis_index, rec, receiveFinalizationRecord) + .check_consistent() } /// Send a transaction to consensus. Return whether the operation succeeded @@ -1993,7 +1997,8 @@ impl ConsensusContainer { }; let return_code = ConsensusFfiResponse::try_from(result) - .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)); + .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)) + .check_consistent(); if return_code == ConsensusFfiResponse::Success { (Some(out_hash.into()), return_code) } else { @@ -2054,6 +2059,7 @@ impl ConsensusContainer { ConsensusFfiResponse::try_from(result) .unwrap_or_else(|code| panic!("Unknown FFI return code: {}", code)) + .check_consistent() } /// Gets baker status of the node along with the baker ID @@ -2105,7 +2111,7 @@ impl ConsensusContainer { let len = path_bytes.len(); let response = unsafe { importBlocks(consensus, path_bytes.as_ptr(), len as i64) }; - match ConsensusFfiResponse::try_from(response)? { + match ConsensusFfiResponse::try_from(response)?.check_consistent() { ConsensusFfiResponse::Success => Ok(()), other => bail!("Error during block import: {}", other), } diff --git a/concordium-node/src/consensus_ffi/helpers.rs b/concordium-node/src/consensus_ffi/helpers.rs index 808cffdd0..ea2ba290b 100644 --- a/concordium-node/src/consensus_ffi/helpers.rs +++ b/concordium-node/src/consensus_ffi/helpers.rs @@ -190,6 +190,8 @@ pub enum ConsensusFfiResponse { InsufficientFunds, #[error("The consensus message is a result of double signing")] DoubleSign, + #[error("Consensus entered an unrecoverable state")] + ConsensusFailure, } impl ConsensusFfiResponse { @@ -259,7 +261,8 @@ impl ConsensusFfiResponse { | BakerNotFound | MissingImportFile | ContinueCatchUp - | DoubleSign => false, + | DoubleSign + | ConsensusFailure => false, PendingBlock => packet_type != PacketType::Block, Success | PendingFinalization | Asynchronous => true, } @@ -276,6 +279,14 @@ impl ConsensusFfiResponse { "invalid" } } + + /// Panic if the response indicates an unrecoverable consensus failure. + pub fn check_consistent(self) -> Self { + if let ConsensusFfiResponse::ConsensusFailure = self { + panic!("Consensus entered an unrecoverable state."); + } + self + } } #[derive(Debug, Error)] @@ -331,6 +342,7 @@ impl TryFrom for ConsensusFfiResponse { 29 => Ok(MaxBlockEnergyExceeded), 30 => Ok(InsufficientFunds), 31 => Ok(DoubleSign), + 32 => Ok(ConsensusFailure), _ => Err(ConsensusFfiResponseConversionError { unknown_code: value, }),