{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Conway.Rules.GovCert (
ConwayGOVCERT,
ConwayGovCertPredFailure (..),
ConwayGovCertEnv (..),
computeDRepExpiry,
)
where
import Cardano.Ledger.BaseTypes (
EpochNo,
Mismatch (..),
Relation (..),
ShelleyBase,
StrictMaybe,
addEpochInterval,
strictMaybe,
)
import Cardano.Ledger.Binary (
DecCBOR (..),
EncCBOR (..),
)
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOVCERT)
import Cardano.Ledger.Conway.Governance (
Committee (..),
GovAction (..),
GovActionPurpose (..),
GovActionState (..),
GovPurposeId,
ProposalProcedure (..),
)
import Cardano.Ledger.Conway.State (
ConwayEraCertState (..),
VState (..),
csCommitteeCredsL,
vsCommitteeStateL,
vsDRepsL,
vsNumDormantEpochsL,
)
import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..))
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRepState (..), drepAnchorL, drepDepositL, drepExpiryL)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.State (
CommitteeAuthorization (..),
CommitteeState (..),
EraCertState (..),
dsUnifiedL,
)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Slotting.Slot (EpochInterval, binOpEpochNo)
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Control.State.Transition.Extended (
BaseM,
Environment,
Event,
PredicateFailure,
STS,
Signal,
State,
TRC (TRC),
TransitionRule,
failOnJust,
judgmentContext,
transitionRules,
(?!),
)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Typeable (Typeable)
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (.~), (^.))
import NoThunks.Class (NoThunks (..))
data ConwayGovCertEnv era = ConwayGovCertEnv
{ forall era. ConwayGovCertEnv era -> PParams era
cgcePParams :: PParams era
, forall era. ConwayGovCertEnv era -> EpochNo
cgceCurrentEpoch :: EpochNo
, forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
, forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
}
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayGovCertEnv era) x -> ConwayGovCertEnv era
forall era x. ConwayGovCertEnv era -> Rep (ConwayGovCertEnv era) x
$cto :: forall era x. Rep (ConwayGovCertEnv era) x -> ConwayGovCertEnv era
$cfrom :: forall era x. ConwayGovCertEnv era -> Rep (ConwayGovCertEnv era) x
Generic)
instance EraPParams era => EncCBOR (ConwayGovCertEnv era) where
encCBOR :: ConwayGovCertEnv era -> Encoding
encCBOR x :: ConwayGovCertEnv era
x@(ConwayGovCertEnv PParams era
_ EpochNo
_ StrictMaybe (Committee era)
_ Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
_) =
let ConwayGovCertEnv {Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
PParams era
StrictMaybe (Committee era)
EpochNo
cgceCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
cgceCurrentEpoch :: EpochNo
cgcePParams :: PParams era
cgceCommitteeProposals :: forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCurrentCommittee :: forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentEpoch :: forall era. ConwayGovCertEnv era -> EpochNo
cgcePParams :: forall era. ConwayGovCertEnv era -> PParams era
..} = ConwayGovCertEnv era
x
in forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
forall t. t -> Encode ('Closed 'Dense) t
Rec forall era.
PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
-> ConwayGovCertEnv era
ConwayGovCertEnv
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
cgcePParams
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
cgceCurrentEpoch
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe (Committee era)
cgceCurrentCommittee
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals
instance EraPParams era => NFData (ConwayGovCertEnv era)
deriving instance EraPParams era => Show (ConwayGovCertEnv era)
deriving instance EraPParams era => Eq (ConwayGovCertEnv era)
data ConwayGovCertPredFailure era
= ConwayDRepAlreadyRegistered (Credential 'DRepRole)
| ConwayDRepNotRegistered (Credential 'DRepRole)
| ConwayDRepIncorrectDeposit (Mismatch 'RelEQ Coin)
| ConwayCommitteeHasPreviouslyResigned (Credential 'ColdCommitteeRole)
| ConwayDRepIncorrectRefund (Mismatch 'RelEQ Coin)
|
ConwayCommitteeIsUnknown (Credential 'ColdCommitteeRole)
deriving (Int -> ConwayGovCertPredFailure era -> ShowS
forall era. Int -> ConwayGovCertPredFailure era -> ShowS
forall era. [ConwayGovCertPredFailure era] -> ShowS
forall era. ConwayGovCertPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayGovCertPredFailure era] -> ShowS
$cshowList :: forall era. [ConwayGovCertPredFailure era] -> ShowS
show :: ConwayGovCertPredFailure era -> String
$cshow :: forall era. ConwayGovCertPredFailure era -> String
showsPrec :: Int -> ConwayGovCertPredFailure era -> ShowS
$cshowsPrec :: forall era. Int -> ConwayGovCertPredFailure era -> ShowS
Show, ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
$c/= :: forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
== :: ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
$c== :: forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayGovCertPredFailure era) x
-> ConwayGovCertPredFailure era
forall era x.
ConwayGovCertPredFailure era
-> Rep (ConwayGovCertPredFailure era) x
$cto :: forall era x.
Rep (ConwayGovCertPredFailure era) x
-> ConwayGovCertPredFailure era
$cfrom :: forall era x.
ConwayGovCertPredFailure era
-> Rep (ConwayGovCertPredFailure era) x
Generic)
type instance EraRuleFailure "GOVCERT" ConwayEra = ConwayGovCertPredFailure ConwayEra
type instance EraRuleEvent "GOVCERT" ConwayEra = VoidEraRule "GOVCERT" ConwayEra
instance InjectRuleFailure "GOVCERT" ConwayGovCertPredFailure ConwayEra
instance NoThunks (ConwayGovCertPredFailure era)
instance NFData (ConwayGovCertPredFailure era)
instance Era era => EncCBOR (ConwayGovCertPredFailure era) where
encCBOR :: ConwayGovCertPredFailure era -> Encoding
encCBOR =
forall (w :: Wrapped) t. Encode w t -> Encoding
encode @_ @(ConwayGovCertPredFailure era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
ConwayDRepAlreadyRegistered Credential 'DRepRole
cred -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'DRepRole
cred
ConwayDRepNotRegistered Credential 'DRepRole
cred -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'DRepRole
cred
ConwayDRepIncorrectDeposit Mismatch 'RelEQ Coin
mm -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBORGroup t => t -> Encode ('Closed 'Dense) t
ToGroup Mismatch 'RelEQ Coin
mm
ConwayCommitteeHasPreviouslyResigned Credential 'ColdCommitteeRole
coldCred -> forall t. t -> Word -> Encode 'Open t
Sum forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned Word
3 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'ColdCommitteeRole
coldCred
ConwayDRepIncorrectRefund Mismatch 'RelEQ Coin
mm -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund Word
4 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBORGroup t => t -> Encode ('Closed 'Dense) t
ToGroup Mismatch 'RelEQ Coin
mm
ConwayCommitteeIsUnknown Credential 'ColdCommitteeRole
coldCred -> forall t. t -> Word -> Encode 'Open t
Sum forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown Word
5 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'ColdCommitteeRole
coldCred
instance Typeable era => DecCBOR (ConwayGovCertPredFailure era) where
decCBOR :: forall s. Decoder s (ConwayGovCertPredFailure era)
decCBOR = forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ConwayGovCertPredFailure" forall a b. (a -> b) -> a -> b
$ \case
Word
0 -> forall t. t -> Decode 'Open t
SumD forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
1 -> forall t. t -> Decode 'Open t
SumD forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
2 -> forall t. t -> Decode 'Open t
SumD forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped).
(EncCBORGroup t, DecCBORGroup t) =>
Decode w t
FromGroup
Word
3 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
4 -> forall t. t -> Decode 'Open t
SumD forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped).
(EncCBORGroup t, DecCBORGroup t) =>
Decode w t
FromGroup
Word
5 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
n -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n
instance
( ConwayEraPParams era
, State (EraRule "GOVCERT" era) ~ CertState era
, Signal (EraRule "GOVCERT" era) ~ ConwayGovCert
, Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
, EraRule "GOVCERT" era ~ ConwayGOVCERT era
, Eq (PredicateFailure (EraRule "GOVCERT" era))
, Show (PredicateFailure (EraRule "GOVCERT" era))
, ConwayEraCertState era
) =>
STS (ConwayGOVCERT era)
where
type State (ConwayGOVCERT era) = CertState era
type Signal (ConwayGOVCERT era) = ConwayGovCert
type Environment (ConwayGOVCERT era) = ConwayGovCertEnv era
type BaseM (ConwayGOVCERT era) = ShelleyBase
type PredicateFailure (ConwayGOVCERT era) = ConwayGovCertPredFailure era
type Event (ConwayGOVCERT era) = Void
transitionRules :: [TransitionRule (ConwayGOVCERT era)]
transitionRules = [forall era.
(ConwayEraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition @era]
conwayGovCertTransition ::
( ConwayEraPParams era
, ConwayEraCertState era
) =>
TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition :: forall era.
(ConwayEraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition = do
TRC
( ConwayGovCertEnv {PParams era
cgcePParams :: PParams era
cgcePParams :: forall era. ConwayGovCertEnv era -> PParams era
cgcePParams, EpochNo
cgceCurrentEpoch :: EpochNo
cgceCurrentEpoch :: forall era. ConwayGovCertEnv era -> EpochNo
cgceCurrentEpoch, StrictMaybe (Committee era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
cgceCurrentCommittee :: forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentCommittee, Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals}
, State (ConwayGOVCERT era)
certState
, Signal (ConwayGOVCERT era)
cert
) <-
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
let ppDRepDeposit :: Coin
ppDRepDeposit = PParams era
cgcePParams forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL
ppDRepActivity :: EpochInterval
ppDRepActivity = PParams era
cgcePParams forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL
checkAndOverwriteCommitteeMemberState :: Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred CommitteeAuthorization
newMemberState = do
let VState {vsCommitteeState :: forall era. VState era -> CommitteeState era
vsCommitteeState = CommitteeState Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds} = State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL
coldCredResigned :: Maybe (Credential 'ColdCommitteeRole)
coldCredResigned =
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldCred Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CommitteeMemberResigned {} -> forall a. a -> Maybe a
Just Credential 'ColdCommitteeRole
coldCred
CommitteeHotCredential {} -> forall a. Maybe a
Nothing
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe (Credential 'ColdCommitteeRole)
coldCredResigned forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned
let isCurrentMember :: Bool
isCurrentMember =
forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe Bool
False (forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole
coldCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers) StrictMaybe (Committee era)
cgceCurrentCommittee
committeeUpdateContainsColdCred :: GovActionState era -> Bool
committeeUpdateContainsColdCred GovActionState {ProposalProcedure era
gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure} =
case forall era. ProposalProcedure era -> GovAction era
pProcGovAction ProposalProcedure era
gasProposalProcedure of
UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
_ Set (Credential 'ColdCommitteeRole)
_ Map (Credential 'ColdCommitteeRole) EpochNo
newMembers UnitInterval
_ -> forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole
coldCred Map (Credential 'ColdCommitteeRole) EpochNo
newMembers
GovAction era
_ -> Bool
False
isPotentialFutureMember :: Bool
isPotentialFutureMember =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GovActionState era -> Bool
committeeUpdateContainsColdCred Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals
Bool
isCurrentMember Bool -> Bool -> Bool
|| Bool
isPotentialFutureMember forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown Credential 'ColdCommitteeRole
coldCred
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
State (ConwayGOVCERT era)
certState
forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
(CommitteeState era)
(Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'ColdCommitteeRole
coldCred CommitteeAuthorization
newMemberState
case Signal (ConwayGOVCERT era)
cert of
ConwayRegDRep Credential 'DRepRole
cred Coin
deposit StrictMaybe Anchor
mAnchor -> do
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered Credential 'DRepRole
cred
Coin
deposit
forall a. Eq a => a -> a -> Bool
== Coin
ppDRepDeposit
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit
Mismatch
{ mismatchSupplied :: Coin
mismatchSupplied = Coin
deposit
, mismatchExpected :: Coin
mismatchExpected = Coin
ppDRepDeposit
}
let drepState :: DRepState
drepState =
DRepState
{ drepExpiry :: EpochNo
drepExpiry =
forall era.
ConwayEraPParams era =>
PParams era -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiryVersioned
PParams era
cgcePParams
EpochNo
cgceCurrentEpoch
(State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL)
, drepAnchor :: StrictMaybe Anchor
drepAnchor = StrictMaybe Anchor
mAnchor
, drepDeposit :: Coin
drepDeposit = Coin
ppDRepDeposit
, drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Monoid a => a
mempty
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
State (ConwayGOVCERT era)
certState
forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole
cred DRepState
drepState
ConwayUnRegDRep Credential 'DRepRole
cred Coin
refund -> do
let mDRepState :: Maybe DRepState
mDRepState = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL)
drepRefundMismatch :: Maybe Coin
drepRefundMismatch = do
DRepState
drepState <- Maybe DRepState
mDRepState
let paidDeposit :: Coin
paidDeposit = DRepState
drepState forall s a. s -> Getting a s a -> a
^. Lens' DRepState Coin
drepDepositL
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Coin
refund forall a. Eq a => a -> a -> Bool
/= Coin
paidDeposit)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
paidDeposit
forall a. Maybe a -> Bool
isJust Maybe DRepState
mDRepState forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Credential 'DRepRole
cred
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe Coin
drepRefundMismatch forall a b. (a -> b) -> a -> b
$ forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
refund
let
certState' :: CertState era
certState' =
State (ConwayGOVCERT era)
certState forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Credential 'DRepRole
cred
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
case Maybe DRepState
mDRepState of
Maybe DRepState
Nothing -> CertState era
certState'
Just DRepState
dRepState ->
CertState era
certState'
forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepState -> Set (Credential 'Staking)
drepDelegs DRepState
dRepState forall k v. Set k -> UView k v -> UMap
UM.⋪ UMap -> UView (Credential 'Staking) DRep
UM.DRepUView (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL)
ConwayUpdateDRep Credential 'DRepRole
cred StrictMaybe Anchor
mAnchor -> do
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Credential 'DRepRole
cred
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
State (ConwayGOVCERT era)
certState
forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
( \DRepState
drepState ->
DRepState
drepState
forall a b. a -> (a -> b) -> b
& Lens' DRepState EpochNo
drepExpiryL
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry
EpochInterval
ppDRepActivity
EpochNo
cgceCurrentEpoch
(State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL)
forall a b. a -> (a -> b) -> b
& Lens' DRepState (StrictMaybe Anchor)
drepAnchorL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe Anchor
mAnchor
)
Credential 'DRepRole
cred
)
ConwayAuthCommitteeHotKey Credential 'ColdCommitteeRole
coldCred Credential 'HotCommitteeRole
hotCred ->
Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred forall a b. (a -> b) -> a -> b
$ Credential 'HotCommitteeRole -> CommitteeAuthorization
CommitteeHotCredential Credential 'HotCommitteeRole
hotCred
ConwayResignCommitteeColdKey Credential 'ColdCommitteeRole
coldCred StrictMaybe Anchor
anchor ->
Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred forall a b. (a -> b) -> a -> b
$ StrictMaybe Anchor -> CommitteeAuthorization
CommitteeMemberResigned StrictMaybe Anchor
anchor
computeDRepExpiryVersioned ::
ConwayEraPParams era =>
PParams era ->
EpochNo ->
EpochNo ->
EpochNo
computeDRepExpiryVersioned :: forall era.
ConwayEraPParams era =>
PParams era -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiryVersioned PParams era
pp EpochNo
currentEpoch EpochNo
numDormantEpochs
| ProtVer -> Bool
HF.bootstrapPhase (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL) =
EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL)
| Bool
otherwise =
EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL) EpochNo
currentEpoch EpochNo
numDormantEpochs
computeDRepExpiry ::
EpochInterval ->
EpochNo ->
EpochNo ->
EpochNo
computeDRepExpiry :: EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry EpochInterval
ppDRepActivity EpochNo
currentEpoch =
(Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo
(-)
(EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
ppDRepActivity)