{-# 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.Deleg (
ConwayDELEG,
ConwayDelegPredFailure (..),
ConwayDelegEnv (..),
) where
import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..))
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
Decode (From, Invalid, SumD, Summands),
Encode (..),
decode,
encode,
(!>),
(<!),
)
import Cardano.Ledger.CertState (
CertState (..),
DState (..),
certDStateL,
certVStateL,
dsUnifiedL,
vsDReps,
vsDRepsL,
)
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayDELEG, ConwayEra)
import Cardano.Ledger.Conway.TxCert (
ConwayDelegCert (ConwayDelegCert, ConwayRegCert, ConwayRegDelegCert, ConwayUnRegCert),
Delegatee (DelegStake, DelegStakeVote, DelegVote),
)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRep (..), DRepState (..))
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.PoolParams (PoolParams)
import qualified Cardano.Ledger.Shelley.HardForks as HF
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData)
import Control.Monad (forM_, guard, unless)
import Control.State.Transition (
BaseM,
Environment,
Event,
PredicateFailure,
STS (..),
Signal,
State,
TRC (TRC),
TransitionRule,
failOnJust,
judgmentContext,
transitionRules,
(?!),
)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Set as Set
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (.~), (^.))
import NoThunks.Class (NoThunks)
data ConwayDelegEnv era = ConwayDelegEnv
{ forall era. ConwayDelegEnv era -> PParams era
cdePParams :: PParams era
, forall era.
ConwayDelegEnv era
-> Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
cdePools :: Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
}
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
forall era x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
$cto :: forall era x. Rep (ConwayDelegEnv era) x -> ConwayDelegEnv era
$cfrom :: forall era x. ConwayDelegEnv era -> Rep (ConwayDelegEnv era) x
Generic)
instance EraPParams era => EncCBOR (ConwayDelegEnv era) where
encCBOR :: ConwayDelegEnv era -> Encoding
encCBOR x :: ConwayDelegEnv era
x@(ConwayDelegEnv PParams era
_ Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
_) =
let ConwayDelegEnv {Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
PParams era
cdePools :: Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
cdePParams :: PParams era
cdePools :: forall era.
ConwayDelegEnv era
-> Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
cdePParams :: forall era. ConwayDelegEnv era -> PParams era
..} = ConwayDelegEnv 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
-> Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
-> ConwayDelegEnv era
ConwayDelegEnv
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
cdePParams
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
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
cdePools
instance (Era era, NFData (PParams era)) => NFData (ConwayDelegEnv era)
deriving instance Eq (PParams era) => Eq (ConwayDelegEnv era)
deriving instance Show (PParams era) => Show (ConwayDelegEnv era)
data ConwayDelegPredFailure era
= IncorrectDepositDELEG Coin
| StakeKeyRegisteredDELEG (Credential 'Staking (EraCrypto era))
| StakeKeyNotRegisteredDELEG (Credential 'Staking (EraCrypto era))
| StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
| DelegateeDRepNotRegisteredDELEG (Credential 'DRepRole (EraCrypto era))
| DelegateeStakePoolNotRegisteredDELEG (KeyHash 'StakePool (EraCrypto era))
deriving (Int -> ConwayDelegPredFailure era -> ShowS
forall era. Int -> ConwayDelegPredFailure era -> ShowS
forall era. [ConwayDelegPredFailure era] -> ShowS
forall era. ConwayDelegPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayDelegPredFailure era] -> ShowS
$cshowList :: forall era. [ConwayDelegPredFailure era] -> ShowS
show :: ConwayDelegPredFailure era -> String
$cshow :: forall era. ConwayDelegPredFailure era -> String
showsPrec :: Int -> ConwayDelegPredFailure era -> ShowS
$cshowsPrec :: forall era. Int -> ConwayDelegPredFailure era -> ShowS
Show, ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
$c/= :: forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
== :: ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
$c== :: forall era.
ConwayDelegPredFailure era -> ConwayDelegPredFailure era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
forall era x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
$cto :: forall era x.
Rep (ConwayDelegPredFailure era) x -> ConwayDelegPredFailure era
$cfrom :: forall era x.
ConwayDelegPredFailure era -> Rep (ConwayDelegPredFailure era) x
Generic)
type instance EraRuleFailure "DELEG" (ConwayEra c) = ConwayDelegPredFailure (ConwayEra c)
type instance EraRuleEvent "DELEG" (ConwayEra c) = VoidEraRule "DELEG" (ConwayEra c)
instance InjectRuleFailure "DELEG" ConwayDelegPredFailure (ConwayEra c)
instance NoThunks (ConwayDelegPredFailure era)
instance NFData (ConwayDelegPredFailure era)
instance Era era => EncCBOR (ConwayDelegPredFailure era) where
encCBOR :: ConwayDelegPredFailure era -> Encoding
encCBOR =
forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
IncorrectDepositDELEG Coin
mCoin ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG @era) 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 Coin
mCoin
StakeKeyRegisteredDELEG Credential 'Staking (EraCrypto era)
stakeCred ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG @era) Word
2 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 'Staking (EraCrypto era)
stakeCred
StakeKeyNotRegisteredDELEG Credential 'Staking (EraCrypto era)
stakeCred ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG @era) 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 'Staking (EraCrypto era)
stakeCred
StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
mCoin ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG @era) Word
4 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 Coin
mCoin
DelegateeDRepNotRegisteredDELEG Credential 'DRepRole (EraCrypto era)
delegatee ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era.
Credential 'DRepRole (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG @era) 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 'DRepRole (EraCrypto era)
delegatee
DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool (EraCrypto era)
delegatee ->
forall t. t -> Word -> Encode 'Open t
Sum (forall era.
KeyHash 'StakePool (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG @era) Word
6 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 KeyHash 'StakePool (EraCrypto era)
delegatee
instance Era era => DecCBOR (ConwayDelegPredFailure era) where
decCBOR :: forall s. Decoder s (ConwayDelegPredFailure era)
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ConwayDelegPredFailure" forall a b. (a -> b) -> a -> b
$ \case
Word
1 -> forall t. t -> Decode 'Open t
SumD forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG forall (w1 :: Wrapped) a t (w :: Density).
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.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
3 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG forall (w1 :: Wrapped) a t (w :: Density).
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. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
5 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'DRepRole (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
Word
6 -> forall t. t -> Decode 'Open t
SumD forall era.
KeyHash 'StakePool (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG forall (w1 :: Wrapped) a t (w :: Density).
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
( EraPParams era
, State (EraRule "DELEG" era) ~ CertState era
, Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era)
, Environment (EraRule "DELEG" era) ~ ConwayDelegEnv era
, EraRule "DELEG" era ~ ConwayDELEG era
) =>
STS (ConwayDELEG era)
where
type State (ConwayDELEG era) = CertState era
type Signal (ConwayDELEG era) = ConwayDelegCert (EraCrypto era)
type Environment (ConwayDELEG era) = ConwayDelegEnv era
type BaseM (ConwayDELEG era) = ShelleyBase
type PredicateFailure (ConwayDELEG era) = ConwayDelegPredFailure era
type Event (ConwayDELEG era) = Void
transitionRules :: [TransitionRule (ConwayDELEG era)]
transitionRules = [forall era. EraPParams era => TransitionRule (ConwayDELEG era)
conwayDelegTransition @era]
conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDELEG era)
conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDELEG era)
conwayDelegTransition = do
TRC
( ConwayDelegEnv PParams era
pp Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
pools
, certState :: State (ConwayDELEG era)
certState@CertState {certDState :: forall era. CertState era -> DState era
certDState = DState {UMap (EraCrypto era)
dsUnified :: forall era. DState era -> UMap (EraCrypto era)
dsUnified :: UMap (EraCrypto era)
dsUnified}}
, Signal (ConwayDELEG era)
cert
) <-
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
let
ppKeyDeposit :: Coin
ppKeyDeposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
checkDepositAgainstPParams :: Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams Coin
deposit =
Coin
deposit forall a. Eq a => a -> a -> Bool
== Coin
ppKeyDeposit forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
deposit
registerStakeCredential :: Credential 'Staking (EraCrypto era) -> UMap (EraCrypto era)
registerStakeCredential Credential 'Staking (EraCrypto era)
stakeCred =
let rdPair :: RDPair
rdPair = CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0) (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
ppKeyDeposit)
in forall k v c. k -> v -> UView c k v -> UMap c
UM.insert Credential 'Staking (EraCrypto era)
stakeCred RDPair
rdPair forall a b. (a -> b) -> a -> b
$ forall c. UMap c -> UView c (Credential 'Staking c) RDPair
UM.RewDepUView UMap (EraCrypto era)
dsUnified
delegStake :: Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> CertState era
-> CertState era
delegStake Credential 'Staking (EraCrypto era)
stakeCred KeyHash 'StakePool (EraCrypto era)
sPool CertState era
cState =
CertState era
cState
forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap (EraCrypto era)
umap ->
forall c.
UMap c -> UView c (Credential 'Staking c) (KeyHash 'StakePool c)
UM.SPoolUView UMap (EraCrypto era)
umap forall c k v. UView c k v -> Map k v -> UMap c
UM.⨃ forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking (EraCrypto era)
stakeCred KeyHash 'StakePool (EraCrypto era)
sPool
delegVote :: Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> CertState era -> CertState era
delegVote Credential 'Staking (EraCrypto era)
stakeCred DRep (EraCrypto era)
dRep CertState era
cState =
let cState' :: CertState era
cState' =
CertState era
cState
forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap (EraCrypto era)
umap ->
forall c. UMap c -> UView c (Credential 'Staking c) (DRep c)
UM.DRepUView UMap (EraCrypto era)
umap forall c k v. UView c k v -> Map k v -> UMap c
UM.⨃ forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking (EraCrypto era)
stakeCred DRep (EraCrypto era)
dRep
dReps :: Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps = forall era.
VState era
-> Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps (forall era. CertState era -> VState era
certVState CertState era
cState)
in case DRep (EraCrypto era)
dRep of
DRepCredential Credential 'DRepRole (EraCrypto era)
targetDRep
| Just DRepState (EraCrypto era)
dRepState <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
targetDRep Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps ->
let dRepState' :: DRepState (EraCrypto era)
dRepState' = DRepState (EraCrypto era)
dRepState {drepDelegs :: Set (Credential 'Staking (EraCrypto era))
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking (EraCrypto era)
stakeCred (forall c. DRepState c -> Set (Credential 'Staking c)
drepDelegs DRepState (EraCrypto era)
dRepState)}
in CertState era
cState' forall a b. a -> (a -> b) -> b
& forall 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 (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole (EraCrypto era)
targetDRep DRepState (EraCrypto era)
dRepState' Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps
DRep (EraCrypto era)
_ -> CertState era
cState'
unDelegVote :: Credential 'Staking (EraCrypto era)
-> VState era -> DRep (EraCrypto era) -> VState era
unDelegVote Credential 'Staking (EraCrypto era)
stakeCred VState era
vState = \case
DRepCredential Credential 'DRepRole (EraCrypto era)
dRepCred ->
let removeDelegation :: DRepState (EraCrypto era) -> DRepState (EraCrypto era)
removeDelegation DRepState (EraCrypto era)
dRepState =
DRepState (EraCrypto era)
dRepState {drepDelegs :: Set (Credential 'Staking (EraCrypto era))
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.delete Credential 'Staking (EraCrypto era)
stakeCred (forall c. DRepState c -> Set (Credential 'Staking c)
drepDelegs DRepState (EraCrypto era)
dRepState)}
in VState era
vState forall a b. a -> (a -> b) -> b
& forall era.
Lens'
(VState era)
(Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
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 (EraCrypto era) -> DRepState (EraCrypto era)
removeDelegation Credential 'DRepRole (EraCrypto era)
dRepCred
DRep (EraCrypto era)
_ -> VState era
vState
processDelegation :: Credential 'Staking (EraCrypto era)
-> Delegatee (EraCrypto era) -> CertState era -> CertState era
processDelegation Credential 'Staking (EraCrypto era)
stakeCred Delegatee (EraCrypto era)
delegatee =
case Delegatee (EraCrypto era)
delegatee of
DelegStake KeyHash 'StakePool (EraCrypto era)
sPool -> forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> CertState era
-> CertState era
delegStake Credential 'Staking (EraCrypto era)
stakeCred KeyHash 'StakePool (EraCrypto era)
sPool
DelegVote DRep (EraCrypto era)
dRep -> forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> CertState era -> CertState era
delegVote Credential 'Staking (EraCrypto era)
stakeCred DRep (EraCrypto era)
dRep
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
sPool DRep (EraCrypto era)
dRep -> forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> CertState era -> CertState era
delegVote Credential 'Staking (EraCrypto era)
stakeCred DRep (EraCrypto era)
dRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> CertState era
-> CertState era
delegStake Credential 'Staking (EraCrypto era)
stakeCred KeyHash 'StakePool (EraCrypto era)
sPool
processUnDelegation :: Credential 'Staking (EraCrypto era)
-> Maybe (Delegatee (EraCrypto era))
-> CertState era
-> CertState era
processUnDelegation Credential 'Staking (EraCrypto era)
_ Maybe (Delegatee (EraCrypto era))
Nothing CertState era
cState = CertState era
cState
processUnDelegation Credential 'Staking (EraCrypto era)
stakeCred (Just Delegatee (EraCrypto era)
delegatee) cState :: CertState era
cState@(CertState {VState era
certVState :: VState era
certVState :: forall era. CertState era -> VState era
certVState}) =
case Delegatee (EraCrypto era)
delegatee of
DelegStake KeyHash 'StakePool (EraCrypto era)
_ -> CertState era
cState
DelegVote DRep (EraCrypto era)
dRep -> CertState era
cState {certVState :: VState era
certVState = forall {era}.
Credential 'Staking (EraCrypto era)
-> VState era -> DRep (EraCrypto era) -> VState era
unDelegVote Credential 'Staking (EraCrypto era)
stakeCred VState era
certVState DRep (EraCrypto era)
dRep}
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
_sPool DRep (EraCrypto era)
dRep -> CertState era
cState {certVState :: VState era
certVState = forall {era}.
Credential 'Staking (EraCrypto era)
-> VState era -> DRep (EraCrypto era) -> VState era
unDelegVote Credential 'Staking (EraCrypto era)
stakeCred VState era
certVState DRep (EraCrypto era)
dRep}
checkStakeKeyNotRegistered :: Credential 'Staking (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking (EraCrypto era)
stakeCred =
forall k c v. k -> UView c k v -> Bool
UM.notMember Credential 'Staking (EraCrypto era)
stakeCred (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
UM.RewDepUView UMap (EraCrypto era)
dsUnified) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential 'Staking (EraCrypto era)
stakeCred
checkStakeKeyIsRegistered :: Credential 'Staking (EraCrypto era)
-> F (Clause (ConwayDELEG era) 'Transition)
(Maybe (Delegatee (EraCrypto era)))
checkStakeKeyIsRegistered Credential 'Staking (EraCrypto era)
stakeCred = do
let mUMElem :: Maybe (UMElem (EraCrypto era))
mUMElem = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking (EraCrypto era)
stakeCred (forall c. UMap c -> Map (Credential 'Staking c) (UMElem c)
UM.umElems UMap (EraCrypto era)
dsUnified)
forall a. Maybe a -> Bool
isJust Maybe (UMElem (EraCrypto era))
mUMElem forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking (EraCrypto era)
stakeCred
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe (UMElem (EraCrypto era))
mUMElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {c}. UMElem c -> Maybe (Delegatee c)
umElemToDelegatee
checkStakeDelegateeRegistered :: Delegatee (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered =
let checkPoolRegistered :: KeyHash 'StakePool (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool (EraCrypto era)
targetPool =
KeyHash 'StakePool (EraCrypto era)
targetPool forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
pools forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
KeyHash 'StakePool (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool (EraCrypto era)
targetPool
checkDRepRegistered :: DRep (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered = \case
DRep (EraCrypto era)
DRepAlwaysAbstain -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DRep (EraCrypto era)
DRepAlwaysNoConfidence -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DRepCredential Credential 'DRepRole (EraCrypto era)
targetDRep -> do
let dReps :: Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps = forall era.
VState era
-> Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps (forall era. CertState era -> VState era
certVState State (ConwayDELEG era)
certState)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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)) forall a b. (a -> b) -> a -> b
$
Credential 'DRepRole (EraCrypto era)
targetDRep forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map
(Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'DRepRole (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Credential 'DRepRole (EraCrypto era)
targetDRep
in \case
DelegStake KeyHash 'StakePool (EraCrypto era)
targetPool -> KeyHash 'StakePool (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool (EraCrypto era)
targetPool
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
targetPool DRep (EraCrypto era)
targetDRep ->
KeyHash 'StakePool (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool (EraCrypto era)
targetPool forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DRep (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep (EraCrypto era)
targetDRep
DelegVote DRep (EraCrypto era)
targetDRep -> DRep (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep (EraCrypto era)
targetDRep
umElemToDelegatee :: UMElem c -> Maybe (Delegatee c)
umElemToDelegatee (UM.UMElem StrictMaybe RDPair
_ Set Ptr
_ StrictMaybe (KeyHash 'StakePool c)
mPool StrictMaybe (DRep c)
mDRep) =
case (StrictMaybe (KeyHash 'StakePool c)
mPool, StrictMaybe (DRep c)
mDRep) of
(StrictMaybe (KeyHash 'StakePool c)
SNothing, StrictMaybe (DRep c)
SNothing) -> forall a. Maybe a
Nothing
(SJust KeyHash 'StakePool c
pool, StrictMaybe (DRep c)
SNothing) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool c
pool
(StrictMaybe (KeyHash 'StakePool c)
SNothing, SJust DRep c
dRep) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. DRep c -> Delegatee c
DelegVote DRep c
dRep
(SJust KeyHash 'StakePool c
pool, SJust DRep c
dRep) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool c
pool DRep c
dRep
case Signal (ConwayDELEG era)
cert of
ConwayRegCert Credential 'Staking (EraCrypto era)
stakeCred StrictMaybe Coin
sMayDeposit -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe Coin
sMayDeposit Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams
Credential 'Staking (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking (EraCrypto era)
stakeCred
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ State (ConwayDELEG era)
certState forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking (EraCrypto era) -> UMap (EraCrypto era)
registerStakeCredential Credential 'Staking (EraCrypto era)
stakeCred
ConwayUnRegCert Credential 'Staking (EraCrypto era)
stakeCred StrictMaybe Coin
sMayRefund -> do
let (Maybe (UMElem (EraCrypto era))
mUMElem, UMap (EraCrypto era)
umap) = forall c.
Credential 'Staking c -> UMap c -> (Maybe (UMElem c), UMap c)
UM.extractStakingCredential Credential 'Staking (EraCrypto era)
stakeCred UMap (EraCrypto era)
dsUnified
mCurDelegatee :: Maybe (Delegatee (EraCrypto era))
mCurDelegatee = Maybe (UMElem (EraCrypto era))
mUMElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {c}. UMElem c -> Maybe (Delegatee c)
umElemToDelegatee
checkInvalidRefund :: Maybe Coin
checkInvalidRefund = do
SJust Coin
suppliedRefund <- forall a. a -> Maybe a
Just StrictMaybe Coin
sMayRefund
UM.UMElem (SJust RDPair
rd) Set Ptr
_ StrictMaybe (KeyHash 'StakePool (EraCrypto era))
_ StrictMaybe (DRep (EraCrypto era))
_ <- Maybe (UMElem (EraCrypto era))
mUMElem
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Coin
suppliedRefund forall a. Eq a => a -> a -> Bool
/= forall a. Compactible a => CompactForm a -> a
UM.fromCompact (RDPair -> CompactForm Coin
UM.rdDeposit RDPair
rd))
forall a. a -> Maybe a
Just Coin
suppliedRefund
checkStakeKeyHasZeroRewardBalance :: Maybe Coin
checkStakeKeyHasZeroRewardBalance = do
UM.UMElem (SJust RDPair
rd) Set Ptr
_ StrictMaybe (KeyHash 'StakePool (EraCrypto era))
_ StrictMaybe (DRep (EraCrypto era))
_ <- Maybe (UMElem (EraCrypto era))
mUMElem
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RDPair -> CompactForm Coin
UM.rdReward RDPair
rd forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty)
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
UM.fromCompact (RDPair -> CompactForm Coin
UM.rdReward RDPair
rd)
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe Coin
checkInvalidRefund forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG
forall a. Maybe a -> Bool
isJust Maybe (UMElem (EraCrypto era))
mUMElem forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking (EraCrypto era)
stakeCred
forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe Coin
checkStakeKeyHasZeroRewardBalance forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {era}.
Credential 'Staking (EraCrypto era)
-> Maybe (Delegatee (EraCrypto era))
-> CertState era
-> CertState era
processUnDelegation Credential 'Staking (EraCrypto era)
stakeCred Maybe (Delegatee (EraCrypto era))
mCurDelegatee forall a b. (a -> b) -> a -> b
$ State (ConwayDELEG era)
certState forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap (EraCrypto era)
umap
ConwayDelegCert Credential 'Staking (EraCrypto era)
stakeCred Delegatee (EraCrypto era)
delegatee -> do
Maybe (Delegatee (EraCrypto era))
mCurDelegatee <- Credential 'Staking (EraCrypto era)
-> F (Clause (ConwayDELEG era) 'Transition)
(Maybe (Delegatee (EraCrypto era)))
checkStakeKeyIsRegistered Credential 'Staking (EraCrypto era)
stakeCred
Delegatee (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee (EraCrypto era)
delegatee
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {era}.
Credential 'Staking (EraCrypto era)
-> Delegatee (EraCrypto era) -> CertState era -> CertState era
processDelegation Credential 'Staking (EraCrypto era)
stakeCred Delegatee (EraCrypto era)
delegatee forall a b. (a -> b) -> a -> b
$ forall {era}.
Credential 'Staking (EraCrypto era)
-> Maybe (Delegatee (EraCrypto era))
-> CertState era
-> CertState era
processUnDelegation Credential 'Staking (EraCrypto era)
stakeCred Maybe (Delegatee (EraCrypto era))
mCurDelegatee State (ConwayDELEG era)
certState
ConwayRegDelegCert Credential 'Staking (EraCrypto era)
stakeCred Delegatee (EraCrypto era)
delegatee Coin
deposit -> do
Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams Coin
deposit
Credential 'Staking (EraCrypto era)
-> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking (EraCrypto era)
stakeCred
Delegatee (EraCrypto era) -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee (EraCrypto era)
delegatee
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall {era}.
Credential 'Staking (EraCrypto era)
-> Delegatee (EraCrypto era) -> CertState era -> CertState era
processDelegation Credential 'Staking (EraCrypto era)
stakeCred Delegatee (EraCrypto era)
delegatee forall a b. (a -> b) -> a -> b
$
State (ConwayDELEG era)
certState forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking (EraCrypto era) -> UMap (EraCrypto era)
registerStakeCredential Credential 'Staking (EraCrypto era)
stakeCred