From 5821b19b086f0581e34dd21a1a131576d7dcbb50 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Wed, 24 May 2023 20:00:19 +0530 Subject: [PATCH] Add CERT and DELEG rules to Conway --- eras/conway/impl/cardano-ledger-conway.cabal | 5 +- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 1 + .../impl/src/Cardano/Ledger/Conway/Era.hs | 27 ++- .../impl/src/Cardano/Ledger/Conway/Rules.hs | 10 +- .../src/Cardano/Ledger/Conway/Rules/Cert.hs | 148 +++++++++++- .../Conway/Rules/{Delegs.hs => Certs.hs} | 112 ++++----- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 219 ++++++++++++++++++ .../src/Cardano/Ledger/Conway/Rules/Ledger.hs | 89 ++++--- .../src/Cardano/Ledger/Conway/Rules/Pool.hs | 59 +++++ .../src/Cardano/Ledger/Conway/Rules/Tally.hs | 2 - .../src/Cardano/Ledger/Conway/Rules/VDel.hs | 65 ++++++ .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 10 +- .../Ledger/Conway/Examples/Consensus.hs | 7 +- .../src/Cardano/Ledger/Pretty/Conway.hs | 69 +++++- .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 7 +- .../src/Test/Cardano/Ledger/Generic/Trace.hs | 7 +- .../src/Test/Cardano/Ledger/Generic/TxGen.hs | 7 +- 17 files changed, 689 insertions(+), 155 deletions(-) rename eras/conway/impl/src/Cardano/Ledger/Conway/Rules/{Delegs.hs => Certs.hs} (60%) create mode 100644 eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs create mode 100644 eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Pool.hs create mode 100644 eras/conway/impl/src/Cardano/Ledger/Conway/Rules/VDel.hs diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 712865503b8..819cd776d1b 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -40,7 +40,10 @@ library Cardano.Ledger.Conway.Era Cardano.Ledger.Conway.UTxO Cardano.Ledger.Conway.Rules.Cert - Cardano.Ledger.Conway.Rules.Delegs + Cardano.Ledger.Conway.Rules.Deleg + Cardano.Ledger.Conway.Rules.Pool + Cardano.Ledger.Conway.Rules.VDel + Cardano.Ledger.Conway.Rules.Certs Cardano.Ledger.Conway.Rules.Enact Cardano.Ledger.Conway.Rules.Epoch Cardano.Ledger.Conway.Rules.Ledger diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index 3a762fd1fa1..f7e382379b2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -54,6 +54,7 @@ instance reapplyTx = reapplyAlonzoTx instance + forall c. ( Crypto c , DSignable c (Hash c EraIndependentTxBody) , EraPlutusContext 'PlutusV2 (ConwayEra c) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs index 153d67c62c4..a50d815cf51 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs @@ -4,7 +4,10 @@ module Cardano.Ledger.Conway.Era ( ConwayEra, ConwayCERT, - ConwayDELEGS, + ConwayDELEG, + ConwayPOOL, + ConwayVDEL, + ConwayCERTS, ConwayTALLY, ConwayNEWEPOCH, ConwayEPOCH, @@ -78,14 +81,26 @@ data ConwayRATIFY era type instance EraRule "RATIFY" (ConwayEra c) = ConwayRATIFY (ConwayEra c) -data ConwayDELEGS era +data ConwayCERTS era -type instance EraRule "DELEGS" (ConwayEra c) = ConwayDELEGS (ConwayEra c) +type instance EraRule "CERTS" (ConwayEra c) = ConwayCERTS (ConwayEra c) data ConwayCERT era type instance EraRule "CERT" (ConwayEra c) = ConwayCERT (ConwayEra c) +data ConwayDELEG era + +type instance EraRule "DELEG" (ConwayEra c) = ConwayDELEG (ConwayEra c) + +data ConwayPOOL era + +type instance EraRule "POOL" (ConwayEra c) = ConwayPOOL (ConwayEra c) + +data ConwayVDEL era + +type instance EraRule "VDEL" (ConwayEra c) = ConwayVDEL (ConwayEra c) + -- Rules inherited from Babbage type instance EraRule "UTXO" (ConwayEra c) = BabbageUTXO (ConwayEra c) @@ -98,16 +113,12 @@ type instance EraRule "BBODY" (ConwayEra c) = AlonzoBBODY (ConwayEra c) -- Rules inherited from Shelley -type instance EraRule "DELEG" (ConwayEra c) = API.ShelleyDELEG (ConwayEra c) - type instance EraRule "LEDGERS" (ConwayEra c) = API.ShelleyLEDGERS (ConwayEra c) type instance EraRule "MIR" (ConwayEra c) = ShelleyMIR (ConwayEra c) type instance EraRule "NEWPP" (ConwayEra c) = ShelleyNEWPP (ConwayEra c) -type instance EraRule "POOL" (ConwayEra c) = API.ShelleyPOOL (ConwayEra c) - type instance EraRule "POOLREAP" (ConwayEra c) = API.ShelleyPOOLREAP (ConwayEra c) type instance EraRule "RUPD" (ConwayEra c) = ShelleyRUPD (ConwayEra c) @@ -116,6 +127,4 @@ type instance EraRule "SNAP" (ConwayEra c) = ShelleySNAP (ConwayEra c) type instance EraRule "TICK" (ConwayEra c) = ShelleyTICK (ConwayEra c) -type instance EraRule "TICKF" (ConwayEra c) = ConwayTICKF (ConwayEra c) - -- ================================================= diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs index 0cb5ca3453f..1ccbd58ae5e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs @@ -1,6 +1,9 @@ module Cardano.Ledger.Conway.Rules ( module Cardano.Ledger.Conway.Rules.Cert, - module Cardano.Ledger.Conway.Rules.Delegs, + module Cardano.Ledger.Conway.Rules.Deleg, + module Cardano.Ledger.Conway.Rules.Pool, + module Cardano.Ledger.Conway.Rules.VDel, + module Cardano.Ledger.Conway.Rules.Certs, module Cardano.Ledger.Conway.Rules.Enact, module Cardano.Ledger.Conway.Rules.Epoch, module Cardano.Ledger.Conway.Rules.Ledger, @@ -13,12 +16,15 @@ module Cardano.Ledger.Conway.Rules ( where import Cardano.Ledger.Conway.Rules.Cert -import Cardano.Ledger.Conway.Rules.Delegs +import Cardano.Ledger.Conway.Rules.Certs +import Cardano.Ledger.Conway.Rules.Deleg import Cardano.Ledger.Conway.Rules.Enact import Cardano.Ledger.Conway.Rules.Epoch import Cardano.Ledger.Conway.Rules.Ledger import Cardano.Ledger.Conway.Rules.NewEpoch +import Cardano.Ledger.Conway.Rules.Pool import Cardano.Ledger.Conway.Rules.Ratify import Cardano.Ledger.Conway.Rules.Tally import Cardano.Ledger.Conway.Rules.Tickf import Cardano.Ledger.Conway.Rules.Utxos +import Cardano.Ledger.Conway.Rules.VDel diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs index 1ccf5775661..fbfdc1f8fdd 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs @@ -1,26 +1,92 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Conway.Rules.Cert ( ConwayCERT, + ConwayCertPredFailure (..), + ConwayCertEvent, ) where import Cardano.Ledger.BaseTypes (ShelleyBase) import Cardano.Ledger.Conway.Core -import Cardano.Ledger.Conway.Era (ConwayCERT) -import Cardano.Ledger.Shelley.API (CertState, DelplEnv) -import Cardano.Ledger.Shelley.Rules (ShelleyDelplEvent, ShelleyDelplPredFailure) -import Control.State.Transition.Extended (STS (..)) +import Cardano.Ledger.Conway.Era (ConwayCERT, ConwayDELEG, ConwayPOOL, ConwayVDEL) +import Cardano.Ledger.Conway.Rules.Deleg (ConwayDelegPredFailure) +import Cardano.Ledger.Conway.Rules.Pool (ConwayPoolPredFailure) +import Cardano.Ledger.Conway.Rules.VDel (ConwayVDelPredFailure, VDelEnv (VDelEnv)) +import Cardano.Ledger.Conway.TxCert (ConwayCommitteeCert, ConwayDelegCert, ConwayTxCert (..)) +import Cardano.Ledger.Shelley.API (CertState (..), DState, DelegEnv (DelegEnv), DelplEnv (DelplEnv), PState, PoolEnv (PoolEnv), VState) +import Control.DeepSeq (NFData) +import Control.State.Transition.Extended (Embed, STS (..), TRC (TRC), TransitionRule, judgmentContext, trans, wrapEvent, wrapFailed) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +data ConwayCertPredFailure era + = DelegFailure (PredicateFailure (EraRule "DELEG" era)) + | PoolFailure (PredicateFailure (EraRule "POOL" era)) + | VDelFailure (PredicateFailure (EraRule "VDEL" era)) + deriving (Generic) + +deriving stock instance + ( Show (PredicateFailure (EraRule "DELEG" era)) + , Show (PredicateFailure (EraRule "POOL" era)) + , Show (PredicateFailure (EraRule "VDEL" era)) + ) => + Show (ConwayCertPredFailure era) + +deriving stock instance + ( Eq (PredicateFailure (EraRule "DELEG" era)) + , Eq (PredicateFailure (EraRule "POOL" era)) + , Eq (PredicateFailure (EraRule "VDEL" era)) + ) => + Eq (ConwayCertPredFailure era) instance + ( NoThunks (PredicateFailure (EraRule "DELEG" era)) + , NoThunks (PredicateFailure (EraRule "POOL" era)) + , NoThunks (PredicateFailure (EraRule "VDEL" era)) + ) => + NoThunks (ConwayCertPredFailure era) + +instance + ( NFData (PredicateFailure (EraRule "DELEG" era)) + , NFData (PredicateFailure (EraRule "POOL" era)) + , NFData (PredicateFailure (EraRule "VDEL" era)) + ) => + NFData (ConwayCertPredFailure era) + +data ConwayCertEvent era + = DelegEvent (Event (ConwayDELEG era)) + | PoolEvent (Event (ConwayPOOL era)) + | VDelEvent (Event (ConwayVDEL era)) + +instance + forall era. ( Era era - , Eq (PredicateFailure (EraRule "DELEG" era)) - , Show (PredicateFailure (EraRule "DELEG" era)) - , Eq (PredicateFailure (EraRule "POOL" era)) - , Show (PredicateFailure (EraRule "POOL" era)) + , State (EraRule "DELEG" era) ~ DState era + , State (EraRule "POOL" era) ~ PState era + , State (EraRule "VDEL" era) ~ VState era + , Environment (EraRule "DELEG" era) ~ DelegEnv era + , Environment (EraRule "POOL" era) ~ PoolEnv era + , Environment (EraRule "VDEL" era) ~ VDelEnv era + , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) + , Signal (EraRule "POOL" era) ~ PoolCert (EraCrypto era) + , Signal (EraRule "VDEL" era) ~ ConwayCommitteeCert (EraCrypto era) + , Embed (EraRule "DELEG" era) (ConwayCERT era) + , Embed (EraRule "POOL" era) (ConwayCERT era) + , Embed (EraRule "VDEL" era) (ConwayCERT era) + , TxCert era ~ ConwayTxCert era ) => STS (ConwayCERT era) where @@ -28,7 +94,67 @@ instance type Signal (ConwayCERT era) = TxCert era type Environment (ConwayCERT era) = DelplEnv era type BaseM (ConwayCERT era) = ShelleyBase - type PredicateFailure (ConwayCERT era) = ShelleyDelplPredFailure era - type Event (ConwayCERT era) = ShelleyDelplEvent era + type PredicateFailure (ConwayCERT era) = ConwayCertPredFailure era + type Event (ConwayCERT era) = ConwayCertEvent era + + transitionRules = [certTransition @era] - transitionRules = undefined +certTransition :: + forall era. + ( State (EraRule "DELEG" era) ~ DState era + , State (EraRule "POOL" era) ~ PState era + , State (EraRule "VDEL" era) ~ VState era + , Environment (EraRule "DELEG" era) ~ DelegEnv era + , Environment (EraRule "POOL" era) ~ PoolEnv era + , Environment (EraRule "VDEL" era) ~ VDelEnv era + , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) + , Signal (EraRule "POOL" era) ~ PoolCert (EraCrypto era) + , Signal (EraRule "VDEL" era) ~ ConwayCommitteeCert (EraCrypto era) + , Embed (EraRule "DELEG" era) (ConwayCERT era) + , Embed (EraRule "POOL" era) (ConwayCERT era) + , Embed (EraRule "VDEL" era) (ConwayCERT era) + , TxCert era ~ ConwayTxCert era + ) => + TransitionRule (ConwayCERT era) +certTransition = do + TRC (DelplEnv slot ptr pp acnt, cState@CertState {certDState, certPState, certVState}, c) <- judgmentContext + case c of + ConwayTxCertDeleg delegCert -> do + newDState <- trans @(EraRule "DELEG" era) $ TRC (DelegEnv slot ptr acnt pp, certDState, delegCert) + pure $ cState {certDState = newDState} + ConwayTxCertPool poolCert -> do + newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState, poolCert) + pure $ cState {certPState = newPState} + ConwayTxCertCommittee committeeCert -> do + newVState <- trans @(EraRule "VDEL" era) $ TRC (VDelEnv, certVState, committeeCert) + pure $ cState {certVState = newVState} + +instance + ( Era era + , STS (ConwayDELEG era) + , PredicateFailure (EraRule "DELEG" era) ~ ConwayDelegPredFailure era + ) => + Embed (ConwayDELEG era) (ConwayCERT era) + where + wrapFailed = DelegFailure + wrapEvent = DelegEvent + +instance + ( Era era + , STS (ConwayPOOL era) + , PredicateFailure (EraRule "POOL" era) ~ ConwayPoolPredFailure era + ) => + Embed (ConwayPOOL era) (ConwayCERT era) + where + wrapFailed = PoolFailure + wrapEvent = PoolEvent + +instance + ( Era era + , STS (ConwayVDEL era) + , PredicateFailure (EraRule "VDEL" era) ~ ConwayVDelPredFailure era + ) => + Embed (ConwayVDEL era) (ConwayCERT era) + where + wrapFailed = VDelFailure + wrapEvent = VDelEvent diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Delegs.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs similarity index 60% rename from eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Delegs.hs rename to eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs index 4714ddf1811..e63a5782702 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Delegs.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -13,10 +14,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Ledger.Conway.Rules.Delegs ( - ConwayDELEGS, - ConwayDelegsPredFailure (..), - ConwayDelegsEvent (..), +module Cardano.Ledger.Conway.Rules.Certs ( + ConwayCERTS, + ConwayCertsPredFailure (..), + ConwayCertsEvent (..), ) where import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, mkCertIxPartial) @@ -29,27 +30,21 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( NoThunks (ConwayDelegsPredFailure era) +deriving stock instance + Eq (PredicateFailure (EraRule "CERT" era)) => + Eq (ConwayCertsPredFailure era) + +deriving stock instance + Show (PredicateFailure (EraRule "CERT" era)) => + Show (ConwayCertsPredFailure era) + +instance + NoThunks (PredicateFailure (EraRule "CERT" era)) => + NoThunks (ConwayCertsPredFailure era) + +newtype ConwayCertsEvent era = CertEvent (Event (EraRule "CERT" era)) instance ( Era era , EncCBOR (PredicateFailure (EraRule "CERT" era)) ) => - EncCBOR (ConwayDelegsPredFailure era) + EncCBOR (ConwayCertsPredFailure era) where encCBOR = encode . \case DelegateeNotRegisteredDELEG kh -> Sum (DelegateeNotRegisteredDELEG @era) 0 !> To kh - WithdrawalsNotInRewardsDELEGS rs -> Sum (WithdrawalsNotInRewardsDELEGS @era) 1 !> To rs + WithdrawalsNotInRewardsCERTS rs -> Sum (WithdrawalsNotInRewardsCERTS @era) 1 !> To rs CertFailure x -> Sum (CertFailure @era) 2 !> To x instance ( Era era , DecCBOR (PredicateFailure (EraRule "CERT" era)) ) => - DecCBOR (ConwayDelegsPredFailure era) + DecCBOR (ConwayCertsPredFailure era) where decCBOR = decode $ Summands "ConwayTallyPredFailure" $ \case 0 -> SumD DelegateeNotRegisteredDELEG SumD WithdrawalsNotInRewardsDELEGS SumD WithdrawalsNotInRewardsCERTS SumD CertFailure Invalid k -deriving instance - Eq (PredicateFailure (EraRule "CERT" era)) => - Eq (ConwayDelegsPredFailure era) -deriving instance - Show (PredicateFailure (EraRule "CERT" era)) => - Show (ConwayDelegsPredFailure era) - -newtype ConwayDelegsEvent era = CertEvent (Event (EraRule "CERT" era)) - instance ( EraTx era , ShelleyEraTxBody era , State (EraRule "CERT" era) ~ CertState era , Signal (EraRule "CERT" era) ~ TxCert era , Environment (EraRule "CERT" era) ~ DelplEnv era - , EraRule "DELEGS" era ~ ConwayDELEGS era - , Embed (EraRule "CERT" era) (ConwayDELEGS era) + , Embed (EraRule "CERT" era) (ConwayCERTS era) ) => - STS (ConwayDELEGS era) + STS (ConwayCERTS era) where - type State (ConwayDELEGS era) = CertState era - type Signal (ConwayDELEGS era) = Seq (TxCert era) - type Environment (ConwayDELEGS era) = DelegsEnv era - type BaseM (ConwayDELEGS era) = ShelleyBase + type State (ConwayCERTS era) = CertState era + type Signal (ConwayCERTS era) = Seq (TxCert era) + type Environment (ConwayCERTS era) = DelegsEnv era + type BaseM (ConwayCERTS era) = ShelleyBase type - PredicateFailure (ConwayDELEGS era) = - ConwayDelegsPredFailure era - type Event (ConwayDELEGS era) = ConwayDelegsEvent era + PredicateFailure (ConwayCERTS era) = + ConwayCertsPredFailure era + type Event (ConwayCERTS era) = ConwayCertsEvent era - transitionRules = [conwayDelegsTransition @era] + transitionRules = [conwayCertsTransition @era] -conwayDelegsTransition :: +conwayCertsTransition :: forall era. ( EraTx era , ShelleyEraTxBody era , State (EraRule "CERT" era) ~ CertState era - , Embed (EraRule "CERT" era) (ConwayDELEGS era) + , Embed (EraRule "CERT" era) (ConwayCERTS era) , Environment (EraRule "CERT" era) ~ DelplEnv era , Signal (EraRule "CERT" era) ~ TxCert era - , EraRule "DELEGS" era ~ ConwayDELEGS era ) => - TransitionRule (ConwayDELEGS era) -conwayDelegsTransition = do + TransitionRule (ConwayCERTS era) +conwayCertsTransition = do TRC (env@(DelegsEnv slot txIx pp tx acnt), certState, certificates) <- judgmentContext network <- liftSTS $ asks networkId @@ -158,12 +154,12 @@ conwayDelegsTransition = do Empty -> do let dState = certDState certState withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL - validateTrans WithdrawalsNotInRewardsDELEGS $ + validateTrans WithdrawalsNotInRewardsCERTS $ validateZeroRewards dState withdrawals network pure $ certState {certDState = drainWithdrawals dState withdrawals} gamma :|> c -> do certState' <- - trans @(ConwayDELEGS era) $ TRC (env, certState, gamma) + trans @(ConwayCERTS era) $ TRC (env, certState, gamma) validateTrans DelegateeNotRegisteredDELEG $ validateDelegationRegistered certState' c -- It is impossible to have 65535 number of certificates in a @@ -175,21 +171,11 @@ conwayDelegsTransition = do instance ( Era era , STS (ConwayCERT era) - , BaseM (ConwayCERT era) ~ ShelleyBase - , PredicateFailure (ConwayCERT era) ~ ShelleyDelplPredFailure era - , Event (ConwayCERT era) ~ ShelleyDelplEvent era - , Embed (EraRule "POOL" era) (ShelleyDELPL era) - , Embed (EraRule "DELEG" era) (ShelleyDELPL era) - , State (EraRule "POOL" era) ~ PState era - , State (EraRule "DELEG" era) ~ DState era - , Environment (EraRule "POOL" era) ~ PoolEnv era - , Environment (EraRule "DELEG" era) ~ DelegEnv era - , Signal (EraRule "POOL" era) ~ TxCert era - , Signal (EraRule "DELEG" era) ~ TxCert era - , PredicateFailure (EraRule "CERT" era) ~ ShelleyDelplPredFailure era - , Event (EraRule "CERT" era) ~ ShelleyDelplEvent era + , BaseM (EraRule "CERT" era) ~ ShelleyBase + , Event (EraRule "CERT" era) ~ ConwayCertEvent era + , PredicateFailure (EraRule "CERT" era) ~ ConwayCertPredFailure era ) => - Embed (ConwayCERT era) (ConwayDELEGS era) + Embed (ConwayCERT era) (ConwayCERTS era) where wrapFailed = CertFailure wrapEvent = CertEvent diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs new file mode 100644 index 00000000000..72b1ffcaf15 --- /dev/null +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Conway.Rules.Deleg ( + ConwayDELEG, + ConwayDelegEvent (..), + ConwayDelegPredFailure (..), +) where + +import Cardano.Ledger.BaseTypes ( + ShelleyBase, + StrictMaybe (SJust, SNothing), + maybeToStrictMaybe, + ) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders ( + Decode (From, Invalid, SumD, Summands), + Encode (Sum, To), + decode, + encode, + (!>), + ( EncCBOR (ConwayDelegPredFailure era) where + encCBOR = + encode . \case + IncorrectDepositDELEG mCoin -> + Sum (IncorrectDepositDELEG @era) 1 + !> To mCoin + StakeKeyAlreadyRegisteredDELEG stakeCred -> + Sum (StakeKeyAlreadyRegisteredDELEG @era) 2 + !> To stakeCred + StakeKeyNotRegisteredDELEG stakeCred -> + Sum (StakeKeyNotRegisteredDELEG @era) 3 + !> To stakeCred + StakeKeyHasNonZeroAccountBalanceDELEG mCoin -> + Sum (StakeKeyHasNonZeroAccountBalanceDELEG @era) 4 + !> To mCoin + DRepAlreadyRegisteredForStakeKeyDELEG stakeCred -> + Sum (DRepAlreadyRegisteredForStakeKeyDELEG @era) 5 + !> To stakeCred + WrongCertificateTypeDELEG -> + Sum (WrongCertificateTypeDELEG @era) 6 + +instance Era era => DecCBOR (ConwayDelegPredFailure era) where + decCBOR = decode $ Summands "ConwayDelegPredFailure" $ \case + 1 -> SumD IncorrectDepositDELEG SumD StakeKeyAlreadyRegisteredDELEG SumD StakeKeyNotRegisteredDELEG SumD StakeKeyHasNonZeroAccountBalanceDELEG SumD DRepAlreadyRegisteredForStakeKeyDELEG SumD WrongCertificateTypeDELEG + n -> Invalid n + +newtype ConwayDelegEvent era = DelegEvent (Event (EraRule "DELEG" era)) + +instance + ( EraPParams era + , State (EraRule "DELEG" era) ~ DState era + , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) + , Environment (EraRule "DELEG" era) ~ DelegEnv era + , EraRule "DELEG" era ~ ConwayDELEG era + ) => + STS (ConwayDELEG era) + where + type State (ConwayDELEG era) = DState era + type Signal (ConwayDELEG era) = ConwayDelegCert (EraCrypto era) + type Environment (ConwayDELEG era) = DelegEnv era + type BaseM (ConwayDELEG era) = ShelleyBase + type PredicateFailure (ConwayDELEG era) = ConwayDelegPredFailure era + type Event (ConwayDELEG era) = ConwayDelegEvent era + + transitionRules = [conwayDelegTransition @era] + +conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDELEG era) +conwayDelegTransition = do + TRC + ( DelegEnv _slot _ptr _acnt pp + , dState@DState {dsUnified} + , c + ) <- + judgmentContext + let pd = pp ^. ppKeyDepositL + case c of + ConwayRegCert stakeCred sMayDeposit -> do + checkDepositAgainstPParams pd sMayDeposit + checkStakeKeyNotAlreadyRegistered stakeCred dsUnified + pure $ dState {dsUnified = acceptDepositForStakeKey stakeCred dsUnified pd} + ConwayUnRegCert stakeCred sMayDeposit -> do + checkStakeKeyIsAlreadyRegistered stakeCred dsUnified + checkStakeKeyHasZeroBalance stakeCred dsUnified + unless (sMayDeposit == SNothing) $ checkDepositAgainstPayedDeposit stakeCred dsUnified sMayDeposit + let umRDRemoved = Set.singleton stakeCred UM.⋪ UM.RewDepUView dsUnified + umSPoolRemoved = Set.singleton stakeCred UM.⋪ UM.SPoolUView umRDRemoved + newUMap = UM.PtrUView umSPoolRemoved UM.⋫ Set.singleton stakeCred -- Although we don't care about Ptrs in Conway, we remove them when we can. + pure $ dState {dsUnified = newUMap} + ConwayDelegCert stakeCred delegatee -> do + checkStakeKeyIsAlreadyRegistered stakeCred dsUnified + pure $ + dState + { dsUnified = processDelegation stakeCred delegatee dsUnified + } + ConwayRegDelegCert stakeCred delegatee coin -> do + coin + == pd + ?! IncorrectDepositDELEG (SJust coin) + checkStakeKeyNotAlreadyRegistered stakeCred dsUnified + -- checkDRepNotAlreadyRegistered stakeCred dsUnified -- TODO: @aniketd to confirm + pure $ + dState + { dsUnified = + processDelegation stakeCred delegatee $ + acceptDepositForStakeKey stakeCred dsUnified pd + } + where + acceptDepositForStakeKey stakeCred dsUnified pd = + UM.RewDepUView dsUnified + UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError pd)) + delegStake stakeCred sPool dsUnified = + UM.SPoolUView dsUnified + UM.⨃ Map.singleton stakeCred sPool + delegVote stakeCred dRep dsUnified = + UM.DRepUView dsUnified + UM.⨃ Map.singleton stakeCred dRep + processDelegation stakeCred delegatee dsUnified = + case delegatee of + DelegStake sPool -> delegStake stakeCred sPool dsUnified + DelegVote dRep -> delegVote stakeCred dRep dsUnified + DelegStakeVote sPool dRep -> delegVote stakeCred dRep $ delegStake stakeCred sPool dsUnified + checkDepositAgainstPParams pd sMayDeposit = + sMayDeposit + == SNothing + || sMayDeposit + == SJust pd + ?! IncorrectDepositDELEG sMayDeposit + checkDepositAgainstPayedDeposit stakeCred dsUnified sMayDeposit = + sMayDeposit + == fmap (UM.fromCompact . UM.rdDeposit) (maybeToStrictMaybe $ UM.lookup stakeCred $ RewDepUView dsUnified) + ?! IncorrectDepositDELEG sMayDeposit + checkStakeKeyNotAlreadyRegistered stakeCred dsUnified = + ( UM.notMember stakeCred (RewDepUView dsUnified) + && UM.notMember stakeCred (SPoolUView dsUnified) + ) + ?! StakeKeyAlreadyRegisteredDELEG stakeCred + checkStakeKeyIsAlreadyRegistered stakeCred dsUnified = + UM.member stakeCred (RewDepUView dsUnified) + ?! StakeKeyNotRegisteredDELEG stakeCred + -- checkDRepNotAlreadyRegistered stakeCred dsUnified = -- TODO: @aniketd to confirm + -- UM.notMember stakeCred (DRepUView dsUnified) + -- ?! DRepAlreadyRegisteredForStakeKeyDELEG stakeCred + checkStakeKeyHasZeroBalance stakeCred dsUnified = + let mReward = UM.rdReward <$> UM.lookup stakeCred (RewDepUView dsUnified) + in Just mempty + == mReward + ?! StakeKeyHasNonZeroAccountBalanceDELEG (UM.fromCompact <$> mReward) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index 20cb2201ad2..e3460808ca0 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -32,13 +32,13 @@ import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Block (txid) import Cardano.Ledger.Conway.Core -import Cardano.Ledger.Conway.Era (ConwayDELEGS, ConwayLEDGER, ConwayTALLY) +import Cardano.Ledger.Conway.Era (ConwayCERTS, ConwayLEDGER, ConwayTALLY) import Cardano.Ledger.Conway.Governance ( ConwayGovernance (..), ConwayTallyState, GovernanceProcedure (..), ) -import Cardano.Ledger.Conway.Rules.Delegs (ConwayDelegsEvent, ConwayDelegsPredFailure) +import Cardano.Ledger.Conway.Rules.Certs (ConwayCertsEvent, ConwayCertsPredFailure) import Cardano.Ledger.Conway.Rules.Tally (ConwayTallyPredFailure, TallyEnv (..)) import Cardano.Ledger.Conway.Tx (AlonzoEraTx (..)) import Cardano.Ledger.Crypto (Crypto (..)) @@ -50,7 +50,7 @@ import Cardano.Ledger.Shelley.LedgerState ( obligationCertState, ) import Cardano.Ledger.Shelley.Rules ( - DelegsEnv (..), + DelegsEnv (DelegsEnv), DelplEnv, LedgerEnv (..), ShelleyLEDGERS, @@ -82,14 +82,14 @@ import NoThunks.Class (NoThunks (..)) data ConwayLedgerPredFailure era = ConwayUtxowFailure (PredicateFailure (EraRule "UTXOW" era)) - | ConwayDelegsFailure (PredicateFailure (EraRule "DELEGS" era)) + | ConwayCertsFailure (PredicateFailure (EraRule "CERTS" era)) | ConwayTallyFailure (PredicateFailure (EraRule "TALLY" era)) -- Subtransition Failures deriving (Generic) deriving instance ( Era era , Eq (PredicateFailure (EraRule "UTXOW" era)) - , Eq (PredicateFailure (EraRule "DELEGS" era)) + , Eq (PredicateFailure (EraRule "CERTS" era)) , Eq (PredicateFailure (EraRule "TALLY" era)) ) => Eq (ConwayLedgerPredFailure era) @@ -97,7 +97,7 @@ deriving instance deriving instance ( Era era , Show (PredicateFailure (EraRule "UTXOW" era)) - , Show (PredicateFailure (EraRule "DELEGS" era)) + , Show (PredicateFailure (EraRule "CERTS" era)) , Show (PredicateFailure (EraRule "TALLY" era)) ) => Show (ConwayLedgerPredFailure era) @@ -105,7 +105,7 @@ deriving instance instance ( Era era , NoThunks (PredicateFailure (EraRule "UTXOW" era)) - , NoThunks (PredicateFailure (EraRule "DELEGS" era)) + , NoThunks (PredicateFailure (EraRule "CERTS" era)) , NoThunks (PredicateFailure (EraRule "TALLY" era)) ) => NoThunks (ConwayLedgerPredFailure era) @@ -113,7 +113,7 @@ instance instance ( Era era , NFData (PredicateFailure (EraRule "UTXOW" era)) - , NFData (PredicateFailure (EraRule "DELEGS" era)) + , NFData (PredicateFailure (EraRule "CERTS" era)) , NFData (PredicateFailure (EraRule "TALLY" era)) ) => NFData (ConwayLedgerPredFailure era) @@ -121,7 +121,7 @@ instance instance ( Era era , EncCBOR (PredicateFailure (EraRule "UTXOW" era)) - , EncCBOR (PredicateFailure (EraRule "DELEGS" era)) + , EncCBOR (PredicateFailure (EraRule "CERTS" era)) , EncCBOR (PredicateFailure (EraRule "TALLY" era)) ) => EncCBOR (ConwayLedgerPredFailure era) @@ -129,13 +129,13 @@ instance encCBOR = encode . \case ConwayUtxowFailure x -> Sum (ConwayUtxowFailure @era) 1 !> To x - ConwayDelegsFailure x -> Sum (ConwayDelegsFailure @era) 2 !> To x + ConwayCertsFailure x -> Sum (ConwayCertsFailure @era) 2 !> To x ConwayTallyFailure x -> Sum (ConwayTallyFailure @era) 3 !> To x instance ( Era era , DecCBOR (PredicateFailure (EraRule "UTXOW" era)) - , DecCBOR (PredicateFailure (EraRule "DELEGS" era)) + , DecCBOR (PredicateFailure (EraRule "CERTS" era)) , DecCBOR (PredicateFailure (EraRule "TALLY" era)) ) => DecCBOR (ConwayLedgerPredFailure era) @@ -143,13 +143,13 @@ instance decCBOR = decode $ Summands "ConwayLedgerPredFailure" $ \case 1 -> SumD ConwayUtxowFailure SumD ConwayDelegsFailure SumD ConwayCertsFailure SumD ConwayTallyFailure Invalid n data ConwayLedgerEvent era = UtxowEvent (Event (EraRule "UTXOW" era)) - | DelegsEvent (Event (EraRule "DELEGS" era)) + | CertsEvent (Event (EraRule "CERTS" era)) | TallyEvent (Event (EraRule "TALLY" era)) instance @@ -158,16 +158,16 @@ instance , GovernanceState era ~ ConwayGovernance era , Embed (EraRule "UTXOW" era) (ConwayLEDGER era) , Embed (EraRule "TALLY" era) (ConwayLEDGER era) - , Embed (EraRule "DELEGS" era) (ConwayLEDGER era) + , Embed (EraRule "CERTS" era) (ConwayLEDGER era) , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "CERTS" era) ~ CertState era + , State (EraRule "TALLY" era) ~ ConwayTallyState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Environment (EraRule "DELEGS" era) ~ DelegsEnv era - , State (EraRule "DELEGS" era) ~ CertState era + , Environment (EraRule "CERTS" era) ~ DelegsEnv era + , Environment (EraRule "TALLY" era) ~ TallyEnv era , Signal (EraRule "UTXOW" era) ~ Tx era - , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) + , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "TALLY" era) ~ Seq (GovernanceProcedure era) - , Environment (EraRule "TALLY" era) ~ TallyEnv era - , State (EraRule "TALLY" era) ~ ConwayTallyState era ) => STS (ConwayLEDGER era) where @@ -195,8 +195,8 @@ instance [ PostCondition "Deposit pot must equal obligation" ( \(TRC (_, _, _)) - (LedgerState utxoSt dpstate) -> - obligationCertState dpstate + (LedgerState utxoSt certState) -> + obligationCertState certState == utxosDeposited utxoSt ) ] @@ -213,16 +213,16 @@ ledgerTransition :: , Environment (someLEDGER era) ~ LedgerEnv era , Embed (EraRule "UTXOW" era) (someLEDGER era) , Embed (EraRule "TALLY" era) (someLEDGER era) - , Embed (EraRule "DELEGS" era) (someLEDGER era) - , Environment (EraRule "DELEGS" era) ~ DelegsEnv era - , State (EraRule "DELEGS" era) ~ CertState era - , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) - , Environment (EraRule "UTXOW" era) ~ UtxoEnv era + , Embed (EraRule "CERTS" era) (someLEDGER era) , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "CERTS" era) ~ CertState era + , State (EraRule "TALLY" era) ~ ConwayTallyState era + , Environment (EraRule "UTXOW" era) ~ UtxoEnv era + , Environment (EraRule "TALLY" era) ~ TallyEnv era + , Environment (EraRule "CERTS" era) ~ DelegsEnv era , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "TALLY" era) ~ Seq (GovernanceProcedure era) - , Environment (EraRule "TALLY" era) ~ TallyEnv era - , State (EraRule "TALLY" era) ~ ConwayTallyState era , BaseM (someLEDGER era) ~ ShelleyBase , STS (someLEDGER era) ) => @@ -231,10 +231,10 @@ ledgerTransition = do TRC (LedgerEnv slot txIx pp account, LedgerState utxoSt certState, tx) <- judgmentContext let txBody = tx ^. bodyTxL - dpstate' <- + certState' <- if tx ^. isValidTxL == IsValid True then - trans @(EraRule "DELEGS" era) $ + trans @(EraRule "CERTS" era) $ TRC ( DelegsEnv slot txIx pp tx account , certState @@ -243,7 +243,7 @@ ledgerTransition = do else pure certState let dstate = certDState certState - genDelegs = dsGenDelegs dstate + genCerts = dsGenDelegs dstate let govProcedures = (GovernanceVotingProcedure <$> txBody ^. votingProceduresTxBodyL) @@ -263,11 +263,11 @@ ledgerTransition = do utxoSt' <- trans @(EraRule "UTXOW" era) $ TRC - ( UtxoEnv @era slot pp certState genDelegs + ( UtxoEnv @era slot pp certState genCerts , utxoSt {utxosGovernance = govSt {cgTally = tallySt'}} , tx ) - pure $ LedgerState utxoSt' dpstate' + pure $ LedgerState utxoSt' certState' instance ( Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) @@ -296,35 +296,34 @@ instance instance ( EraTx era , ShelleyEraTxBody era - , Embed (EraRule "CERT" era) (ConwayDELEGS era) + , Embed (EraRule "CERT" era) (ConwayCERTS era) , State (EraRule "CERT" era) ~ CertState era , Environment (EraRule "CERT" era) ~ DelplEnv era , Signal (EraRule "CERT" era) ~ TxCert era - , PredicateFailure (EraRule "DELEGS" era) ~ ConwayDelegsPredFailure era - , Event (EraRule "DELEGS" era) ~ ConwayDelegsEvent era - , Embed (EraRule "CERT" era) (ConwayDELEGS era) - , EraRule "DELEGS" era ~ ConwayDELEGS era + , PredicateFailure (EraRule "CERTS" era) ~ ConwayCertsPredFailure era + , Event (EraRule "CERTS" era) ~ ConwayCertsEvent era + , EraRule "CERTS" era ~ ConwayCERTS era ) => - Embed (ConwayDELEGS era) (ConwayLEDGER era) + Embed (ConwayCERTS era) (ConwayLEDGER era) where - wrapFailed = ConwayDelegsFailure - wrapEvent = DelegsEvent + wrapFailed = ConwayCertsFailure + wrapEvent = CertsEvent instance ( Embed (EraRule "UTXOW" era) (ConwayLEDGER era) - , Embed (EraRule "DELEGS" era) (ConwayLEDGER era) + , Embed (EraRule "CERTS" era) (ConwayLEDGER era) , Embed (EraRule "TALLY" era) (ConwayLEDGER era) , AlonzoEraTx era , ConwayEraTxBody era , GovernanceState era ~ ConwayGovernance era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Environment (EraRule "DELEGS" era) ~ DelegsEnv era + , Environment (EraRule "CERTS" era) ~ DelegsEnv era , Environment (EraRule "TALLY" era) ~ TallyEnv era , Signal (EraRule "UTXOW" era) ~ Tx era - , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) + , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "TALLY" era) ~ Seq (GovernanceProcedure era) , State (EraRule "UTXOW" era) ~ UTxOState era - , State (EraRule "DELEGS" era) ~ CertState era + , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "TALLY" era) ~ ConwayTallyState era , PredicateFailure (EraRule "LEDGER" era) ~ ConwayLedgerPredFailure era , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Pool.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Pool.hs new file mode 100644 index 00000000000..0d477105aea --- /dev/null +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Pool.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Conway.Rules.Pool ( + ConwayPOOL, + ConwayPoolEvent (..), + ConwayPoolPredFailure (..), +) +where + +import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.CertState (PState) +import Cardano.Ledger.Conway.Era (ConwayPOOL) +import Cardano.Ledger.Core (Era (EraCrypto), EraRule) +import Cardano.Ledger.Shelley.API (PoolCert, PoolEnv) +import Control.DeepSeq (NFData) +import Control.State.Transition ( + BaseM, + Environment, + Event, + PredicateFailure, + STS, + Signal, + State, + transitionRules, + ) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks (..)) + +data ConwayPoolPredFailure era + = ConwayPoolPredFailure + deriving (Show, Eq, Generic, NoThunks, NFData) + +newtype ConwayPoolEvent era = PoolEvent (Event (EraRule "POOL" era)) + +instance + ( Era era + , State (EraRule "POOL" era) ~ PState era + , Signal (EraRule "POOL" era) ~ PoolCert (EraCrypto era) + , Environment (EraRule "POOL" era) ~ PoolEnv era + , EraRule "POOL" era ~ ConwayPOOL era + ) => + STS (ConwayPOOL era) + where + type State (ConwayPOOL era) = PState era + type Signal (ConwayPOOL era) = PoolCert (EraCrypto era) + type Environment (ConwayPOOL era) = PoolEnv era + type BaseM (ConwayPOOL era) = ShelleyBase + type PredicateFailure (ConwayPOOL era) = ConwayPoolPredFailure era + type Event (ConwayPOOL era) = ConwayPoolEvent era + + transitionRules = undefined diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Tally.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Tally.hs index d0d6085abee..842a3b2537d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Tally.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Tally.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -12,7 +11,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/VDel.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/VDel.hs new file mode 100644 index 00000000000..caca252323c --- /dev/null +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/VDel.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Conway.Rules.VDel ( + ConwayVDEL, + ConwayVDelEvent (..), + VDelEnv (..), + ConwayVDelPredFailure, +) +where + +import Cardano.Ledger.BaseTypes ( + ShelleyBase, + ) +import Cardano.Ledger.CertState (VState) +import Cardano.Ledger.Conway.Era (ConwayVDEL) +import Cardano.Ledger.Conway.TxCert (ConwayCommitteeCert) +import Cardano.Ledger.Core (Era (EraCrypto), EraRule) +import Control.DeepSeq (NFData) +import Control.State.Transition ( + BaseM, + Environment, + Event, + PredicateFailure, + STS, + Signal, + State, + transitionRules, + ) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks (..)) + +data ConwayVDelPredFailure era + deriving (Show, Eq, Generic, NoThunks, NFData) + +data VDelEnv era = VDelEnv + +newtype ConwayVDelEvent era = VDelEvent (Event (EraRule "VDEL" era)) + +instance + ( Era era + , State (EraRule "VDEL" era) ~ VState era + , Signal (EraRule "VDEL" era) ~ ConwayCommitteeCert (EraCrypto era) + , Environment (EraRule "VDEL" era) ~ VDelEnv era + , EraRule "VDEL" era ~ ConwayVDEL era + , Eq (PredicateFailure (EraRule "VDEL" era)) + , Show (PredicateFailure (EraRule "VDEL" era)) + ) => + STS (ConwayVDEL era) + where + type State (ConwayVDEL era) = VState era + type Signal (ConwayVDEL era) = ConwayCommitteeCert (EraCrypto era) + type Environment (ConwayVDEL era) = VDelEnv era + type BaseM (ConwayVDEL era) = ShelleyBase + type PredicateFailure (ConwayVDEL era) = ConwayVDelPredFailure era + type Event (ConwayVDEL era) = ConwayVDelEvent era + + transitionRules = undefined diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index cbc247a211f..e8eefe1dd26 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -204,7 +204,7 @@ instance Era era => Arbitrary (ConwayTallyPredFailure era) where instance ( Arbitrary (PredicateFailure (EraRule "UTXOW" era)) - , Arbitrary (PredicateFailure (EraRule "DELEGS" era)) + , Arbitrary (PredicateFailure (EraRule "CERTS" era)) , Arbitrary (PredicateFailure (EraRule "TALLY" era)) ) => Arbitrary (ConwayLedgerPredFailure era) @@ -212,7 +212,7 @@ instance arbitrary = oneof [ ConwayUtxowFailure <$> arbitrary - , ConwayDelegsFailure <$> arbitrary + , ConwayCertsFailure <$> arbitrary , ConwayTallyFailure <$> arbitrary ] @@ -261,17 +261,17 @@ instance where arbitrary = undefined --- DELEGS +-- CERTS instance ( Era era , Arbitrary (PredicateFailure (EraRule "CERT" era)) ) => - Arbitrary (ConwayDelegsPredFailure era) + Arbitrary (ConwayCertsPredFailure era) where arbitrary = oneof [ DelegateeNotRegisteredDELEG <$> arbitrary - , WithdrawalsNotInRewardsDELEGS <$> arbitrary + , WithdrawalsNotInRewardsCERTS <$> arbitrary , CertFailure <$> arbitrary ] diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs index 57512699910..c5e83e53803 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs @@ -30,7 +30,7 @@ import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway (Conway) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) -import Cardano.Ledger.Conway.Rules (ConwayDELEGS, ConwayDelegsPredFailure (..), ConwayLEDGER) +import Cardano.Ledger.Conway.Rules (ConwayCERTS, ConwayCertsPredFailure (..), ConwayLEDGER) import Cardano.Ledger.Conway.Translation () import Cardano.Ledger.Conway.Tx (AlonzoTx (..)) import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) @@ -70,7 +70,8 @@ import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE -- ============================================================== -- | ShelleyLedgerExamples for Conway era -ledgerExamplesConway :: SLE.ShelleyLedgerExamples Conway +ledgerExamplesConway :: + SLE.ShelleyLedgerExamples Conway ledgerExamplesConway = SLE.ShelleyLedgerExamples { SLE.sleBlock = SLE.exampleShelleyLedgerBlock exampleTransactionInBlock @@ -79,7 +80,7 @@ ledgerExamplesConway = , SLE.sleApplyTxError = ApplyTxError $ pure $ - wrapFailed @(ConwayDELEGS Conway) @(ConwayLEDGER Conway) $ + wrapFailed @(ConwayCERTS Conway) @(ConwayLEDGER Conway) $ DelegateeNotRegisteredDELEG @Conway (SLE.mkKeyHash 1) , SLE.sleRewardsCredentials = Set.fromList diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs index 5932dfee8ef..eb91f2b0db3 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs @@ -34,9 +34,13 @@ import Cardano.Ledger.Conway.Governance ( VotingProcedure (..), ) import Cardano.Ledger.Conway.Rules ( - ConwayDelegsPredFailure (..), + ConwayCertPredFailure (..), + ConwayCertsPredFailure (..), + ConwayDelegPredFailure (..), ConwayLedgerPredFailure (..), + ConwayPoolPredFailure, ConwayTallyPredFailure, + ConwayVDelPredFailure, EnactState (..), PredicateFailure, RatifyState (..), @@ -55,6 +59,7 @@ import Cardano.Ledger.Pretty ( ppAuxiliaryDataHash, ppCoin, ppKeyHash, + ppMaybe, ppNetwork, ppPoolCert, ppRecord, @@ -218,13 +223,13 @@ instance Crypto c => PrettyA (PParamsUpdate (ConwayEra c)) where instance ( PrettyA (PredicateFailure (EraRule "UTXOW" era)) - , PrettyA (PredicateFailure (EraRule "DELEGS" era)) + , PrettyA (PredicateFailure (EraRule "CERTS" era)) , PrettyA (PredicateFailure (EraRule "TALLY" era)) ) => PrettyA (ConwayLedgerPredFailure era) where prettyA (ConwayUtxowFailure x) = prettyA x - prettyA (ConwayDelegsFailure x) = prettyA x + prettyA (ConwayCertsFailure x) = prettyA x prettyA (ConwayTallyFailure x) = prettyA x instance PrettyA (ConwayTallyPredFailure era) where @@ -307,14 +312,68 @@ instance instance PrettyA (PredicateFailure (EraRule "CERT" era)) => - PrettyA (ConwayDelegsPredFailure era) + PrettyA (ConwayCertsPredFailure era) where prettyA (DelegateeNotRegisteredDELEG x) = ppRecord "DelegateeNotRegisteredDELEG" [("KeyHash", prettyA x)] - prettyA (WithdrawalsNotInRewardsDELEGS x) = + prettyA (WithdrawalsNotInRewardsCERTS x) = ppRecord "WithdrawalsNotInRewardsDELEGS" [("Missing Withdrawals", prettyA x)] prettyA (CertFailure x) = prettyA x + +instance + ( PrettyA (PredicateFailure (EraRule "DELEG" era)) + , PrettyA (PredicateFailure (EraRule "POOL" era)) + , PrettyA (PredicateFailure (EraRule "VDEL" era)) + ) => + PrettyA (ConwayCertPredFailure era) + where + prettyA = \case + DelegFailure x -> + ppRecord + "ConwayDelegFailure" + [("DELEG", prettyA x)] + PoolFailure x -> + ppRecord + "ConwayPoolFailure" + [("POOL", prettyA x)] + VDelFailure x -> + ppRecord + "ConwayVDelFailure" + [("VDEL", prettyA x)] + +instance PrettyA (ConwayDelegPredFailure era) where + prettyA = \case + IncorrectDepositDELEG x -> + ppRecord + "IncorrectDepositDELEG" + [("Coin", prettyA x)] + StakeKeyAlreadyRegisteredDELEG x -> + ppRecord + "StakeKeyAlreadyRegisteredDELEG" + [("Credential", prettyA x)] + StakeKeyNotRegisteredDELEG x -> + ppRecord + "StakeKeyNotRegisteredDELEG" + [("Credential", prettyA x)] + StakeKeyHasNonZeroAccountBalanceDELEG x -> + ppRecord + "StakeKeyHasNonZeroAccountBalanceDELEG" + [("Coin", ppMaybe ppCoin x)] + DRepAlreadyRegisteredForStakeKeyDELEG x -> + ppRecord + "DRepAlreadyRegisteredForStakeKeyDELEG" + [("Credential", prettyA x)] + WrongCertificateTypeDELEG -> + ppRecord + "WrongCertificateTypeDELEG" + [] + +instance PrettyA (ConwayPoolPredFailure era) where + prettyA = const $ ppRecord "ConwayPoolPredFailure" [] + +instance PrettyA (ConwayVDelPredFailure era) where + prettyA = const $ ppRecord "ConwayVDelPredFailure" [] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index b7b4c8b36ab..e09ebe0fba8 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -32,8 +32,6 @@ import Cardano.Ledger.BaseTypes ( ) import Cardano.Ledger.Block (Block (..), txid) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway.Rules (ConwayDelegsPredFailure (..), ConwayLedgerPredFailure (..)) - import Cardano.Ledger.Credential ( Credential (..), StakeCredential, @@ -674,9 +672,8 @@ makeTooBig proof@(Alonzo _) = makeTooBig proof@(Babbage _) = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . LedgerFailure . DelegsFailure . DelplFailure . PoolFailure $ PoolMedataHashTooBig (coerceKeyRole . hashKey . vKey $ someKeys proof) (hashsize @Mock + 1) -makeTooBig proof@(Conway _) = - ShelleyInAlonzoBbodyPredFailure . LedgersFailure . LedgerFailure . ConwayDelegsFailure . CertFailure . PoolFailure $ - PoolMedataHashTooBig (coerceKeyRole . hashKey . vKey $ someKeys proof) (hashsize @Mock + 1) +-- makeTooBig proof@(Conway _) = +-- ShelleyInAlonzoBbodyPredFailure . LedgersFailure . LedgerFailure . ConwayCertsFailure . CertFailure . PoolFailure $ ConwayPoolPredFailure -- FIXME: @aniketd: This needs fixing after POOL rules are implemented for Conway makeTooBig proof = error ("makeTooBig does not work in era " ++ show proof) coldKeys :: CC.Crypto c => KeyPair 'BlockIssuer c diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs index 72a1f89ede7..a052566258f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs @@ -236,7 +236,9 @@ pcSmallUTxO proof u txs = ppMap pcTxIn (shortTxOut proof) m raiseMockError :: forall era. - (Reflect era, PrettyA (TxCert era)) => + ( Reflect era + , PrettyA (TxCert era) + ) => Word64 -> SlotNo -> EpochState era -> @@ -565,7 +567,8 @@ chainTest proof n gsize = testProperty message action -- Here is where we can add some properties for traces: pure (_traceInitState trace1 === initState) -testTraces :: Int -> TestTree +testTraces :: + Int -> TestTree testTraces n = testGroup "MockChainTrace" diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs index 1c9e80b5d1b..d68f04cb2c1 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs @@ -1125,8 +1125,11 @@ instance -- in a way that is Era Agnostic applySTSByProof :: - forall era. - (Era era, GoodCrypto (EraCrypto era)) => + forall era c. + ( Era era + , EraCrypto era ~ c + , GoodCrypto (EraCrypto era) + ) => Proof era -> RuleContext 'Transition (EraRule "LEDGER" era) -> Either [PredicateFailure (EraRule "LEDGER" era)] (State (EraRule "LEDGER" era))