{-# LANGUAGE BangPatterns #-}
{-# 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 (..),
  processDelegation,
) where

import Cardano.Ledger.BaseTypes (ProtVer (..), ShelleyBase, StrictMaybe (..), natVersion)
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.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) PoolParams
cdePools :: Map (KeyHash 'StakePool) PoolParams
  }
  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) PoolParams
_) =
    let ConwayDelegEnv {Map (KeyHash 'StakePool) PoolParams
PParams era
cdePools :: Map (KeyHash 'StakePool) PoolParams
cdePParams :: PParams era
cdePools :: forall era.
ConwayDelegEnv era -> Map (KeyHash 'StakePool) PoolParams
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) PoolParams -> 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) PoolParams
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)
  | StakeKeyNotRegisteredDELEG (Credential 'Staking)
  | StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
  | DelegateeDRepNotRegisteredDELEG (Credential 'DRepRole)
  | DelegateeStakePoolNotRegisteredDELEG (KeyHash 'StakePool)
  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 = ConwayDelegPredFailure ConwayEra

type instance EraRuleEvent "DELEG" ConwayEra = VoidEraRule "DELEG" ConwayEra

instance InjectRuleFailure "DELEG" ConwayDelegPredFailure ConwayEra

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
stakeCred ->
        forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'Staking -> 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
stakeCred
      StakeKeyNotRegisteredDELEG Credential 'Staking
stakeCred ->
        forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'Staking -> 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
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
delegatee ->
        forall t. t -> Word -> Encode 'Open t
Sum (forall era. Credential 'DRepRole -> 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
delegatee
      DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool
delegatee ->
        forall t. t -> Word -> Encode 'Open t
Sum (forall era. KeyHash 'StakePool -> 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
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 -> 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 -> 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 -> 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 -> 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
  , 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
  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 :: EraPParams era => TransitionRule (ConwayDELEG era)
conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDELEG era)
conwayDelegTransition = do
  TRC
    ( ConwayDelegEnv PParams era
pp Map (KeyHash 'StakePool) PoolParams
pools
      , certState :: State (ConwayDELEG era)
certState@CertState {certDState :: forall era. CertState era -> DState era
certDState = DState {UMap
dsUnified :: forall era. DState era -> UMap
dsUnified :: UMap
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
    pv :: ProtVer
pv = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
    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 -> UMap
registerStakeCredential Credential 'Staking
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. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
stakeCred RDPair
rdPair forall a b. (a -> b) -> a -> b
$ UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
dsUnified
    checkStakeKeyNotRegistered :: Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred =
      forall k v. k -> UView k v -> Bool
UM.notMember Credential 'Staking
stakeCred (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
dsUnified) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential 'Staking
stakeCred
    checkStakeKeyIsRegistered :: Credential 'Staking
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
checkStakeKeyIsRegistered Credential 'Staking
stakeCred = do
      let mUMElem :: Maybe UMElem
mUMElem = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
stakeCred (UMap -> Map (Credential 'Staking) UMElem
UM.umElems UMap
dsUnified)
      forall a. Maybe a -> Bool
isJust Maybe UMElem
mUMElem forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking
stakeCred
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe UMElem
mUMElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UMElem -> Maybe Delegatee
umElemToDelegatee
    checkStakeDelegateeRegistered :: Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered =
      let checkPoolRegistered :: KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool =
            KeyHash 'StakePool
targetPool forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'StakePool) PoolParams
pools forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool
targetPool
          checkDRepRegistered :: DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered = \case
            DRep
DRepAlwaysAbstain -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            DRep
DRepAlwaysNoConfidence -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            DRepCredential Credential 'DRepRole
targetDRep -> do
              let dReps :: Map (Credential 'DRepRole) DRepState
dReps = forall era. VState era -> Map (Credential 'DRepRole) DRepState
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
targetDRep forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Credential 'DRepRole) DRepState
dReps forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Credential 'DRepRole
targetDRep
       in \case
            DelegStake KeyHash 'StakePool
targetPool -> KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool
            DelegStakeVote KeyHash 'StakePool
targetPool DRep
targetDRep ->
              KeyHash 'StakePool -> Rule (ConwayDELEG era) 'Transition ()
checkPoolRegistered KeyHash 'StakePool
targetPool forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep
targetDRep
            DelegVote DRep
targetDRep -> DRep -> Rule (ConwayDELEG era) 'Transition ()
checkDRepRegistered DRep
targetDRep
  case Signal (ConwayDELEG era)
cert of
    ConwayRegCert Credential 'Staking
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 -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
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
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking -> UMap
registerStakeCredential Credential 'Staking
stakeCred
    ConwayUnRegCert Credential 'Staking
stakeCred StrictMaybe Coin
sMayRefund -> do
      let (Maybe UMElem
mUMElem, UMap
umap) = Credential 'Staking -> UMap -> (Maybe UMElem, UMap)
UM.extractStakingCredential Credential 'Staking
stakeCred UMap
dsUnified
          mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe UMElem
mUMElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UMElem -> Maybe Delegatee
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)
_ StrictMaybe DRep
_ <- Maybe UMElem
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)
_ StrictMaybe DRep
_ <- Maybe UMElem
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
mUMElem forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking
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
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
stakeCred Maybe Delegatee
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
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap
umap
    ConwayDelegCert Credential 'Staking
stakeCred Delegatee
delegatee -> do
      Maybe Delegatee
mCurDelegatee <- Credential 'Staking
-> F (Clause (ConwayDELEG era) 'Transition) (Maybe Delegatee)
checkStakeKeyIsRegistered Credential 'Staking
stakeCred
      Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee
delegatee
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall era.
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal (ProtVer -> Version
pvMajor ProtVer
pv forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
delegatee State (ConwayDELEG era)
certState
    ConwayRegDelegCert Credential 'Staking
stakeCred Delegatee
delegatee Coin
deposit -> do
      Coin -> Rule (ConwayDELEG era) 'Transition ()
checkDepositAgainstPParams Coin
deposit
      Credential 'Staking -> Rule (ConwayDELEG era) 'Transition ()
checkStakeKeyNotRegistered Credential 'Staking
stakeCred
      Delegatee -> Rule (ConwayDELEG era) 'Transition ()
checkStakeDelegateeRegistered Delegatee
delegatee
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall era.
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal (ProtVer -> Version
pvMajor ProtVer
pv forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Credential 'Staking
stakeCred forall a. Maybe a
Nothing Delegatee
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
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Credential 'Staking -> UMap
registerStakeCredential Credential 'Staking
stakeCred

-- | Apply new delegation, while properly cleaning up older delegations. This function
-- does not enforce that delegatee is registered, that has to be handled by the caller.
processDelegation ::
  -- | Delegator
  Credential 'Staking ->
  -- | New delegatee
  Delegatee ->
  CertState era ->
  CertState era
processDelegation :: forall era.
Credential 'Staking -> Delegatee -> CertState era -> CertState era
processDelegation Credential 'Staking
stakeCred Delegatee
newDelegatee !CertState era
certState = CertState era
certState'
  where
    !certState' :: CertState era
certState' = forall era.
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal Bool
False Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
newDelegatee CertState era
certState
    mUMElem :: Maybe UMElem
mUMElem = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
stakeCred (UMap -> Map (Credential 'Staking) UMElem
UM.umElems (forall era. DState era -> UMap
dsUnified (forall era. CertState era -> DState era
certDState CertState era
certState)))
    mCurDelegatee :: Maybe Delegatee
mCurDelegatee = Maybe UMElem
mUMElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UMElem -> Maybe Delegatee
umElemToDelegatee

-- | Same as `processDelegation`, except it expects the current delegation supplied as an
-- argument, because in ledger rules we already have it readily available.
processDelegationInternal ::
  -- | Preserve the buggy behavior where DRep delegations are not updated correctly (See #4772)
  Bool ->
  -- | Delegator
  Credential 'Staking ->
  -- | Current delegatee for the above stake credential that needs to be cleaned up.
  Maybe Delegatee ->
  -- | New delegatee
  Delegatee ->
  CertState era ->
  CertState era
processDelegationInternal :: forall era.
Bool
-> Credential 'Staking
-> Maybe Delegatee
-> Delegatee
-> CertState era
-> CertState era
processDelegationInternal Bool
preserveIncorrectDelegation Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee Delegatee
newDelegatee =
  case Delegatee
newDelegatee of
    DelegStake KeyHash 'StakePool
sPool -> KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
sPool
    DelegVote DRep
dRep -> DRep -> CertState era -> CertState era
delegVote DRep
dRep
    DelegStakeVote KeyHash 'StakePool
sPool DRep
dRep -> DRep -> CertState era -> CertState era
delegVote DRep
dRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
sPool
  where
    delegStake :: KeyHash 'StakePool -> CertState era -> CertState era
delegStake KeyHash 'StakePool
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
dsUnifiedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap
umap ->
          UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
umap forall k v. UView k v -> Map k v -> UMap
UM.⨃ forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
stakeCred KeyHash 'StakePool
sPool
    delegVote :: DRep -> CertState era -> CertState era
delegVote DRep
dRep CertState era
cState =
      let cState' :: CertState era
cState' =
            forall era.
Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
stakeCred Maybe Delegatee
mCurDelegatee 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
dsUnifiedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \UMap
umap ->
                UMap -> UView (Credential 'Staking) DRep
UM.DRepUView UMap
umap forall k v. UView k v -> Map k v -> UMap
UM.⨃ forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
stakeCred DRep
dRep
          dReps :: Map (Credential 'DRepRole) DRepState
dReps
            | Bool
preserveIncorrectDelegation = forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps (forall era. CertState era -> VState era
certVState CertState era
cState)
            | Bool
otherwise = forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps (forall era. CertState era -> VState era
certVState CertState era
cState')
       in case DRep
dRep of
            DRepCredential Credential 'DRepRole
targetDRep
              | Just DRepState
dRepState <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
targetDRep Map (Credential 'DRepRole) DRepState
dReps ->
                  let dRepState' :: DRepState
dRepState' = DRepState
dRepState {drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking
stakeCred (DRepState -> Set (Credential 'Staking)
drepDelegs DRepState
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) DRepState)
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
targetDRep DRepState
dRepState' Map (Credential 'DRepRole) DRepState
dReps
            DRep
_ -> CertState era
cState'

umElemToDelegatee :: UM.UMElem -> Maybe Delegatee
umElemToDelegatee :: UMElem -> Maybe Delegatee
umElemToDelegatee (UM.UMElem StrictMaybe RDPair
_ Set Ptr
_ StrictMaybe (KeyHash 'StakePool)
mPool StrictMaybe DRep
mDRep) =
  case (StrictMaybe (KeyHash 'StakePool)
mPool, StrictMaybe DRep
mDRep) of
    (StrictMaybe (KeyHash 'StakePool)
SNothing, StrictMaybe DRep
SNothing) -> forall a. Maybe a
Nothing
    (SJust KeyHash 'StakePool
pool, StrictMaybe DRep
SNothing) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Delegatee
DelegStake KeyHash 'StakePool
pool
    (StrictMaybe (KeyHash 'StakePool)
SNothing, SJust DRep
dRep) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DRep -> Delegatee
DelegVote DRep
dRep
    (SJust KeyHash 'StakePool
pool, SJust DRep
dRep) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> DRep -> Delegatee
DelegStakeVote KeyHash 'StakePool
pool DRep
dRep

processDRepUnDelegation ::
  Credential 'Staking ->
  Maybe Delegatee ->
  CertState era ->
  CertState era
processDRepUnDelegation :: forall era.
Credential 'Staking
-> Maybe Delegatee -> CertState era -> CertState era
processDRepUnDelegation Credential 'Staking
_ Maybe Delegatee
Nothing CertState era
cState = CertState era
cState
processDRepUnDelegation Credential 'Staking
stakeCred (Just Delegatee
delegatee) cState :: CertState era
cState@(CertState {VState era
certVState :: VState era
certVState :: forall era. CertState era -> VState era
certVState}) =
  case Delegatee
delegatee of
    DelegStake KeyHash 'StakePool
_ -> CertState era
cState
    DelegVote DRep
dRep -> CertState era
cState {certVState :: VState era
certVState = VState era -> DRep -> VState era
unDelegVote VState era
certVState DRep
dRep}
    DelegStakeVote KeyHash 'StakePool
_sPool DRep
dRep -> CertState era
cState {certVState :: VState era
certVState = VState era -> DRep -> VState era
unDelegVote VState era
certVState DRep
dRep}
  where
    unDelegVote :: VState era -> DRep -> VState era
unDelegVote VState era
vState = \case
      DRepCredential Credential 'DRepRole
dRepCred ->
        let removeDelegation :: DRepState -> DRepState
removeDelegation DRepState
dRepState =
              DRepState
dRepState {drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.delete Credential 'Staking
stakeCred (DRepState -> Set (Credential 'Staking)
drepDelegs DRepState
dRepState)}
         in VState era
vState forall a b. a -> (a -> b) -> b
& 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
removeDelegation Credential 'DRepRole
dRepCred
      DRep
_ -> VState era
vState