-
Notifications
You must be signed in to change notification settings - Fork 86
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Fixes #2452. Co-authored-by: Thomas Winant <thomas@well-typed.com>
- Loading branch information
Showing
8 changed files
with
254 additions
and
36 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
167 changes: 167 additions & 0 deletions
167
ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,167 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
|
|
||
| {-# OPTIONS_GHC -Wno-orphans #-} | ||
| module Ouroboros.Consensus.Shelley.Ledger.Inspect ( | ||
| ProtocolUpdate(..) | ||
| , UpdateProposal(..) | ||
| , UpdateState(..) | ||
| ) where | ||
|
|
||
| import Control.Monad | ||
| import Data.List (sortBy) | ||
| import Data.Map.Strict (Map) | ||
| import qualified Data.Map.Strict as Map | ||
| import Data.Ord (comparing) | ||
| import Data.Tuple (swap) | ||
| import Data.Void | ||
| import Data.Word (Word64) | ||
|
|
||
| import Ouroboros.Consensus.Block | ||
| import Ouroboros.Consensus.Config | ||
| import Ouroboros.Consensus.Ledger.Abstract | ||
| import Ouroboros.Consensus.Ledger.Inspect | ||
| import Ouroboros.Consensus.Util | ||
| import Ouroboros.Consensus.Util.Condense | ||
|
|
||
| import Shelley.Spec.Ledger.BaseTypes (strictMaybeToMaybe) | ||
| import qualified Shelley.Spec.Ledger.Genesis as SL | ||
| import qualified Shelley.Spec.Ledger.Keys as SL | ||
| import qualified Shelley.Spec.Ledger.LedgerState as SL | ||
| import qualified Shelley.Spec.Ledger.PParams as SL | ||
|
|
||
| import Ouroboros.Consensus.Shelley.Ledger.Block | ||
| import Ouroboros.Consensus.Shelley.Ledger.Ledger | ||
|
|
||
| data ProtocolUpdate era = ProtocolUpdate { | ||
| protocolUpdateProposal :: UpdateProposal era | ||
| , protocolUpdateState :: UpdateState era | ||
| } | ||
| deriving (Show, Eq) | ||
|
|
||
| -- | Update proposal | ||
| -- | ||
| -- As in Byron, a proposal is a partial map from parameters to their values. | ||
| data UpdateProposal era = UpdateProposal { | ||
| -- | The protocol parameters changed by this update proposal | ||
| -- | ||
| -- An update is /identified/ by how it updates the protocol parameters. | ||
| proposalParams :: SL.PParamsUpdate era | ||
|
|
||
| -- | New version (if changed by this proposal) | ||
| -- | ||
| -- The protocol version itself is also considered to be just another | ||
| -- parameter, and parameters can change /without/ changing the protocol | ||
| -- version, although a convention /could/ be established that the protocol | ||
| -- version must change if any of the parameters do; but the specification | ||
| -- itself does not mandate this. | ||
| -- | ||
| -- We record the version separately for the convenience of the HFC. | ||
| , proposalVersion :: Maybe SL.ProtVer | ||
|
|
||
| -- | The 'EpochNo' the proposal becomes active in, if it is adopted | ||
| , proposalEpoch :: EpochNo | ||
| } | ||
| deriving (Show, Eq) | ||
|
|
||
| -- | Proposal state | ||
| -- | ||
| -- The update mechanism in Shelley is simpler than it is in Byron. There is no | ||
| -- distinction between votes and proposals: to \"vote\" for a proposal one | ||
| -- merely submits the exact same proposal. There is also no separate | ||
| -- endorsement step. The procedure is as follows: | ||
| -- | ||
| -- 1. During each epoch, a genesis key can submit (via its delegates) zero, | ||
| -- one, or many proposals; each submission overrides the previous one. | ||
| -- 2. \"Voting\" (submitting of proposals) ends @2 * stabilityWindow@ slots | ||
| -- (i.e. @6k/f@) before the end of the epoch. In other words, proposals | ||
| -- for the upcoming epoch must be submitted within the first @4k/f@ slots | ||
| -- of this one. | ||
| -- 3. At the end of an epoch, if the majority of nodes (as determined by the | ||
| -- @Quorum@ specification constant, which must be greater than half the | ||
| -- nodes) have most recently submitted the same exact proposal, then it is | ||
| -- adopted. | ||
| -- 4. The next epoch is always started with a clean slate, proposals from the | ||
| -- previous epoch that didn't make it are discarded (except for "future | ||
| -- proposals that are explicitly marked for future epochs). | ||
| data UpdateState era = UpdateState { | ||
| -- | The genesis delegates that voted for this proposal | ||
| proposalVotes :: [SL.KeyHash 'SL.Genesis era] | ||
|
|
||
| -- | Has this proposal reached sufficient votes to be adopted? | ||
| , proposalReachedQuorum :: Bool | ||
| } | ||
| deriving (Show, Eq) | ||
|
|
||
| protocolUpdates :: | ||
| forall era. | ||
| LedgerConfig (ShelleyBlock era) | ||
| -> LedgerState (ShelleyBlock era) | ||
| -> [ProtocolUpdate era] | ||
| protocolUpdates cfg st = [ | ||
| ProtocolUpdate { | ||
| protocolUpdateProposal = UpdateProposal { | ||
| proposalParams = proposal | ||
| , proposalEpoch = succ currentEpoch | ||
| , proposalVersion = strictMaybeToMaybe $ | ||
| SL._protocolVersion proposal | ||
| } | ||
| , protocolUpdateState = UpdateState { | ||
| proposalVotes = votes | ||
| , proposalReachedQuorum = length votes >= fromIntegral quorum | ||
| } | ||
| } | ||
| | (proposal, votes) <- proposalsInv | ||
| ] | ||
| where | ||
| proposalsInv :: [(SL.PParamsUpdate era, [SL.KeyHash 'SL.Genesis era])] | ||
| proposalsInv = | ||
| groupSplit id | ||
| . sortBy (comparing fst) | ||
| $ map swap (Map.toList proposals) | ||
|
|
||
| -- Updated proposed within the proposal window | ||
| proposals :: Map (SL.KeyHash 'SL.Genesis era) (SL.PParamsUpdate era) | ||
| SL.ProposedPPUpdates proposals = | ||
| SL.proposals | ||
| . SL._ppups | ||
| . SL._utxoState | ||
| . SL.esLState | ||
| . SL.nesEs | ||
| . shelleyLedgerState | ||
| $ st | ||
|
|
||
| -- A proposal is accepted if the number of votes is equal to or greater | ||
| -- than the quorum. The quorum itself must be strictly greater than half | ||
| -- the number of genesis keys, but we do not rely on that property here. | ||
| quorum :: Word64 | ||
| quorum = SL.sgUpdateQuorum . shelleyLedgerGenesis $ cfg | ||
|
|
||
| -- The proposals in 'SL.proposals' are for the upcoming epoch | ||
| -- (we ignore 'futureProposals') | ||
| currentEpoch :: EpochNo | ||
| currentEpoch = SL.nesEL . shelleyLedgerState $ st | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Inspection | ||
| -------------------------------------------------------------------------------} | ||
|
|
||
| data ShelleyLedgerUpdate era = | ||
| ShelleyUpdatedProtocolUpdates [ProtocolUpdate era] | ||
| deriving (Show, Eq) | ||
|
|
||
| instance Condense (ShelleyLedgerUpdate era) where | ||
| condense = show | ||
|
|
||
| instance InspectLedger (ShelleyBlock era) where | ||
| type LedgerWarning (ShelleyBlock era) = Void | ||
| type LedgerUpdate (ShelleyBlock era) = ShelleyLedgerUpdate era | ||
|
|
||
| inspectLedger tlc before after = do | ||
| guard $ updatesBefore /= updatesAfter | ||
| return $ LedgerUpdate $ ShelleyUpdatedProtocolUpdates updatesAfter | ||
| where | ||
| updatesBefore, updatesAfter :: [ProtocolUpdate era] | ||
| updatesBefore = protocolUpdates (configLedger tlc) before | ||
| updatesAfter = protocolUpdates (configLedger tlc) after |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.