{-# 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
            -- we don't want to report invalid refund when stake credential is not registered:
            UM.UMElem (SJust RDPair
rd) Set Ptr
_ StrictMaybe (KeyHash 'StakePool (EraCrypto era))
_ StrictMaybe (DRep (EraCrypto era))
_ <- Maybe (UMElem (EraCrypto era))
mUMElem
            -- we return offending refund only when it doesn't match the expected one:
            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