|
8 | 8 |
|
9 | 9 | {-# OPTIONS_GHC -Wno-orphans #-} |
10 | 10 | module Ouroboros.Consensus.Shelley.Ledger.Inspect ( |
11 | | - ProtocolUpdate (..) |
12 | | - , ShelleyLedgerUpdate (..) |
13 | | - , UpdateProposal (..) |
14 | | - , UpdateState (..) |
15 | | - , protocolUpdates |
| 11 | + ShelleyLedgerUpdate (..) |
| 12 | + , pparamsUpdate |
16 | 13 | ) where |
17 | 14 |
|
18 | 15 | import qualified Cardano.Ledger.Shelley.API as SL |
19 | 16 | import qualified Cardano.Ledger.Shelley.Core as Core |
| 17 | +import qualified Cardano.Ledger.Shelley.Governance as SL |
20 | 18 | import qualified Cardano.Ledger.Shelley.LedgerState as SL |
21 | | -import qualified Cardano.Ledger.Shelley.PParams as SL |
22 | 19 | import Control.Monad |
23 | | -import Data.Map.Strict (Map) |
24 | | -import qualified Data.Map.Strict as Map |
25 | | -import Data.Maybe (fromMaybe) |
26 | 20 | import Data.Void |
27 | | -import Data.Word (Word64) |
28 | | -import Lens.Micro.Extras (view) |
| 21 | +import Lens.Micro ((^.)) |
29 | 22 | import Ouroboros.Consensus.Block |
30 | | -import Ouroboros.Consensus.Config |
31 | 23 | import Ouroboros.Consensus.Ledger.Abstract |
32 | 24 | import Ouroboros.Consensus.Ledger.Inspect |
33 | | -import Ouroboros.Consensus.Shelley.Eras (EraCrypto, |
34 | | - ShelleyBasedEra (..)) |
35 | 25 | import Ouroboros.Consensus.Shelley.Ledger.Block |
36 | 26 | import Ouroboros.Consensus.Shelley.Ledger.Ledger |
37 | 27 | import Ouroboros.Consensus.Util.Condense |
38 | 28 |
|
39 | | -data ProtocolUpdate era = ProtocolUpdate { |
40 | | - protocolUpdateProposal :: UpdateProposal era |
41 | | - , protocolUpdateState :: UpdateState (EraCrypto era) |
42 | | - } |
43 | | -deriving instance Eq (Core.PParamsUpdate era) => Eq (ProtocolUpdate era) |
44 | | -deriving instance Show (Core.PParamsUpdate era) => Show (ProtocolUpdate era) |
45 | | - |
46 | | --- | Update proposal |
47 | | --- |
48 | | --- As in Byron, a proposal is a partial map from parameters to their values. |
49 | | -data UpdateProposal era = UpdateProposal { |
50 | | - -- | The protocol parameters changed by this update proposal |
51 | | - -- |
52 | | - -- An update is /identified/ by how it updates the protocol parameters. |
53 | | - proposalParams :: Core.PParamsUpdate era |
54 | | - |
55 | | - -- | New version (if changed by this proposal) |
56 | | - -- |
57 | | - -- The protocol version itself is also considered to be just another |
58 | | - -- parameter, and parameters can change /without/ changing the protocol |
59 | | - -- version, although a convention /could/ be established that the protocol |
60 | | - -- version must change if any of the parameters do; but the specification |
61 | | - -- itself does not mandate this. |
62 | | - -- |
63 | | - -- We record the version separately for the convenience of the HFC. |
64 | | - , proposalVersion :: Maybe SL.ProtVer |
65 | | - |
66 | | - -- | The 'EpochNo' the proposal becomes active in, if it is adopted |
67 | | - , proposalEpoch :: EpochNo |
68 | | - } |
69 | | - |
70 | | -deriving instance Eq (Core.PParamsUpdate era) => Eq (UpdateProposal era) |
71 | | -deriving instance Show (Core.PParamsUpdate era) => Show (UpdateProposal era) |
72 | | - |
73 | | --- | Proposal state |
74 | | --- |
75 | | --- The update mechanism in Shelley is simpler than it is in Byron. There is no |
76 | | --- distinction between votes and proposals: to \"vote\" for a proposal one |
77 | | --- merely submits the exact same proposal. There is also no separate |
78 | | --- endorsement step. The procedure is as follows: |
79 | | --- |
80 | | --- 1. During each epoch, a genesis key can submit (via its delegates) zero, |
81 | | --- one, or many proposals; each submission overrides the previous one. |
82 | | --- 2. \"Voting\" (submitting of proposals) ends @2 * stabilityWindow@ slots |
83 | | --- (i.e. @6k/f@) before the end of the epoch. In other words, proposals |
84 | | --- for the upcoming epoch must be submitted within the first @4k/f@ slots |
85 | | --- of this one. |
86 | | --- 3. At the end of an epoch, if the majority of nodes (as determined by the |
87 | | --- @Quorum@ specification constant, which must be greater than half the |
88 | | --- nodes) have most recently submitted the same exact proposal, then it is |
89 | | --- adopted. |
90 | | --- 4. The next epoch is always started with a clean slate, proposals from the |
91 | | --- previous epoch that didn't make it are discarded (except for "future |
92 | | --- proposals" that are explicitly marked for future epochs). |
93 | | -data UpdateState c = UpdateState { |
94 | | - -- | The genesis delegates that voted for this proposal |
95 | | - proposalVotes :: [SL.KeyHash 'SL.Genesis c] |
96 | | - |
97 | | - -- | Has this proposal reached sufficient votes to be adopted? |
98 | | - , proposalReachedQuorum :: Bool |
99 | | - } |
100 | | - deriving (Show, Eq) |
101 | | - |
102 | | -protocolUpdates :: |
103 | | - forall era proto. ShelleyBasedEra era |
104 | | - => SL.ShelleyGenesis (EraCrypto era) |
105 | | - -> LedgerState (ShelleyBlock proto era) |
106 | | - -> [ProtocolUpdate era] |
107 | | -protocolUpdates genesis st = [ |
108 | | - ProtocolUpdate { |
109 | | - protocolUpdateProposal = UpdateProposal { |
110 | | - proposalParams = proposal |
111 | | - , proposalEpoch = succ currentEpoch |
112 | | - , proposalVersion = getProposedProtocolVersion proposal |
113 | | - } |
114 | | - , protocolUpdateState = UpdateState { |
115 | | - proposalVotes = votes |
116 | | - , proposalReachedQuorum = length votes >= fromIntegral quorum |
117 | | - } |
118 | | - } |
119 | | - | (proposal, votes) <- Map.toList $ invertMap proposals |
120 | | - ] |
121 | | - where |
122 | | - invertMap :: Ord b => Map a b -> Map b [a] |
123 | | - invertMap = Map.fromListWith (<>) . fmap swizzle . Map.toList |
124 | | - where |
125 | | - swizzle (a, b) = (b, [a]) |
126 | | - |
127 | | - -- Updated proposed within the proposal window |
128 | | - proposals :: Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (Core.PParamsUpdate era) |
129 | | - SL.ProposedPPUpdates proposals = |
130 | | - fromMaybe SL.emptyPPPUpdates |
131 | | - . Core.getProposedPPUpdates |
132 | | - . view SL.newEpochStateGovStateL |
133 | | - . shelleyLedgerState |
134 | | - $ st |
135 | | - |
136 | | - -- A proposal is accepted if the number of votes is equal to or greater |
137 | | - -- than the quorum. The quorum itself must be strictly greater than half |
138 | | - -- the number of genesis keys, but we do not rely on that property here. |
139 | | - quorum :: Word64 |
140 | | - quorum = SL.sgUpdateQuorum genesis |
141 | | - |
142 | | - -- The proposals in 'SL.proposals' are for the upcoming epoch |
143 | | - -- (we ignore 'futureProposals') |
144 | | - currentEpoch :: EpochNo |
145 | | - currentEpoch = SL.nesEL . shelleyLedgerState $ st |
146 | | - |
147 | | -{------------------------------------------------------------------------------- |
148 | | - Inspection |
149 | | --------------------------------------------------------------------------------} |
150 | | - |
151 | 29 | data ShelleyLedgerUpdate era = |
152 | | - ShelleyUpdatedProtocolUpdates [ProtocolUpdate era] |
| 30 | + ShelleyUpdatedPParams (Maybe (Core.PParams era)) EpochNo |
153 | 31 |
|
154 | | -deriving instance Eq (Core.PParamsUpdate era) => Eq (ShelleyLedgerUpdate era) |
155 | | -deriving instance Show (Core.PParamsUpdate era) => Show (ShelleyLedgerUpdate era) |
| 32 | +deriving instance Eq (Core.PParams era) => Eq (ShelleyLedgerUpdate era) |
| 33 | +deriving instance Show (Core.PParams era) => Show (ShelleyLedgerUpdate era) |
156 | 34 |
|
157 | | -instance Show (Core.PParamsUpdate era) => Condense (ShelleyLedgerUpdate era) where |
| 35 | +instance Show (Core.PParams era) => Condense (ShelleyLedgerUpdate era) where |
158 | 36 | condense = show |
159 | 37 |
|
160 | 38 | instance ShelleyBasedEra era => InspectLedger (ShelleyBlock proto era) where |
161 | 39 | type LedgerWarning (ShelleyBlock proto era) = Void |
162 | 40 | type LedgerUpdate (ShelleyBlock proto era) = ShelleyLedgerUpdate era |
163 | 41 |
|
164 | | - inspectLedger tlc before after = do |
| 42 | + inspectLedger _tlc before after = do |
165 | 43 | guard $ updatesBefore /= updatesAfter |
166 | | - return $ LedgerUpdate $ ShelleyUpdatedProtocolUpdates updatesAfter |
| 44 | + return $ LedgerUpdate updatesAfter |
167 | 45 | where |
168 | | - genesis :: SL.ShelleyGenesis (EraCrypto era) |
169 | | - genesis = shelleyLedgerGenesis (configLedger tlc) |
170 | 46 |
|
171 | | - updatesBefore, updatesAfter :: [ProtocolUpdate era] |
172 | | - updatesBefore = protocolUpdates genesis before |
173 | | - updatesAfter = protocolUpdates genesis after |
| 47 | + updatesBefore, updatesAfter :: ShelleyLedgerUpdate era |
| 48 | + updatesBefore = pparamsUpdate before |
| 49 | + updatesAfter = pparamsUpdate after |
| 50 | + |
| 51 | +pparamsUpdate :: |
| 52 | + forall era proto. ShelleyBasedEra era |
| 53 | + => LedgerState (ShelleyBlock proto era) |
| 54 | + -> ShelleyLedgerUpdate era |
| 55 | +pparamsUpdate st = |
| 56 | + let nes = shelleyLedgerState st |
| 57 | + in ShelleyUpdatedPParams |
| 58 | + (nes ^. SL.newEpochStateGovStateL . SL.futurePParamsGovStateG) |
| 59 | + (succ (SL.nesEL nes)) |
0 commit comments