{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Certs (
  ConwayCERTS,
  ConwayCertsPredFailure (..),
  ConwayCertsEvent (..),
  CertsEnv (..),
  updateDormantDRepExpiry,
) where

import Cardano.Ledger.BaseTypes (
  EpochNo (EpochNo),
  Globals (..),
  ShelleyBase,
  SlotNo,
  StrictMaybe,
  binOpEpochNo,
 )
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.CertState (VState, certDStateL, certVStateL, vsDRepsL, vsNumDormantEpochsL)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayCERT, ConwayCERTS, ConwayEra)
import Cardano.Ledger.Conway.Governance (
  Committee,
  GovActionPurpose (..),
  GovActionState,
  GovPurposeId,
  Voter (DRepVoter),
  VotingProcedures (unVotingProcedures),
 )
import Cardano.Ledger.Conway.Rules.Cert (CertEnv (CertEnv), ConwayCertEvent, ConwayCertPredFailure)
import Cardano.Ledger.Conway.Rules.Deleg (ConwayDelegPredFailure)
import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure, computeDRepExpiry)
import Cardano.Ledger.DRep (drepExpiryL)
import Cardano.Ledger.Shelley.API (
  CertState (..),
  Coin,
  RewardAccount,
 )
import Cardano.Ledger.Shelley.Rules (
  ShelleyPoolPredFailure,
  drainWithdrawals,
  validateZeroRewards,
 )
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended (
  Embed (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  trans,
  validateTrans,
 )
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import Data.Sequence (Seq (..))
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

data CertsEnv era = CertsEnv
  { forall era. CertsEnv era -> Tx era
certsTx :: !(Tx era)
  , forall era. CertsEnv era -> PParams era
certsPParams :: !(PParams era)
  , forall era. CertsEnv era -> SlotNo
certsSlotNo :: !SlotNo
  , forall era. CertsEnv era -> EpochNo
certsCurrentEpoch :: !EpochNo
  , forall era. CertsEnv era -> StrictMaybe (Committee era)
certsCurrentCommittee :: StrictMaybe (Committee era)
  , forall era.
CertsEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
certsCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CertsEnv era) x -> CertsEnv era
forall era x. CertsEnv era -> Rep (CertsEnv era) x
$cto :: forall era x. Rep (CertsEnv era) x -> CertsEnv era
$cfrom :: forall era x. CertsEnv era -> Rep (CertsEnv era) x
Generic)

instance EraTx era => EncCBOR (CertsEnv era) where
  encCBOR :: CertsEnv era -> Encoding
encCBOR x :: CertsEnv era
x@(CertsEnv Tx era
_ PParams era
_ SlotNo
_ EpochNo
_ StrictMaybe (Committee era)
_ Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
_) =
    let CertsEnv {Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
PParams era
Tx era
StrictMaybe (Committee era)
EpochNo
SlotNo
certsCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
certsCurrentCommittee :: StrictMaybe (Committee era)
certsCurrentEpoch :: EpochNo
certsSlotNo :: SlotNo
certsPParams :: PParams era
certsTx :: Tx era
certsCommitteeProposals :: forall era.
CertsEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
certsCurrentCommittee :: forall era. CertsEnv era -> StrictMaybe (Committee era)
certsCurrentEpoch :: forall era. CertsEnv era -> EpochNo
certsSlotNo :: forall era. CertsEnv era -> SlotNo
certsPParams :: forall era. CertsEnv era -> PParams era
certsTx :: forall era. CertsEnv era -> Tx era
..} = CertsEnv 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.
Tx era
-> PParams era
-> SlotNo
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
-> CertsEnv era
CertsEnv
            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 Tx era
certsTx
            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
certsPParams
            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 SlotNo
certsSlotNo
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
certsCurrentEpoch
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe (Committee era)
certsCurrentCommittee
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
certsCommitteeProposals

deriving instance (EraPParams era, Eq (Tx era)) => Eq (CertsEnv era)
deriving instance (EraPParams era, Show (Tx era)) => Show (CertsEnv era)
instance (EraPParams era, NFData (Tx era)) => NFData (CertsEnv era)

data ConwayCertsPredFailure era
  = -- | Withdrawals that are missing or do not withdrawal the entire amount
    WithdrawalsNotInRewardsCERTS
      !(Map.Map (RewardAccount (EraCrypto era)) Coin)
  | -- | CERT rule subtransition Failures
    CertFailure !(PredicateFailure (EraRule "CERT" era))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
forall era x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
$cto :: forall era x.
Rep (ConwayCertsPredFailure era) x -> ConwayCertsPredFailure era
$cfrom :: forall era x.
ConwayCertsPredFailure era -> Rep (ConwayCertsPredFailure era) x
Generic)

type instance EraRuleFailure "CERTS" (ConwayEra c) = ConwayCertsPredFailure (ConwayEra c)

type instance EraRuleEvent "CERTS" (ConwayEra c) = ConwayCertsEvent (ConwayEra c)

instance InjectRuleFailure "CERTS" ConwayCertsPredFailure (ConwayEra c)

instance InjectRuleFailure "CERTS" ConwayCertPredFailure (ConwayEra c) where
  injectFailure :: ConwayCertPredFailure (ConwayEra c)
-> EraRuleFailure "CERTS" (ConwayEra c)
injectFailure = forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure

instance InjectRuleFailure "CERTS" ConwayDelegPredFailure (ConwayEra c) where
  injectFailure :: ConwayDelegPredFailure (ConwayEra c)
-> EraRuleFailure "CERTS" (ConwayEra c)
injectFailure = forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ShelleyPoolPredFailure (ConwayEra c) where
  injectFailure :: ShelleyPoolPredFailure (ConwayEra c)
-> EraRuleFailure "CERTS" (ConwayEra c)
injectFailure = forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ConwayGovCertPredFailure (ConwayEra c) where
  injectFailure :: ConwayGovCertPredFailure (ConwayEra c)
-> EraRuleFailure "CERTS" (ConwayEra c)
injectFailure = forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

deriving stock instance
  Eq (PredicateFailure (EraRule "CERT" era)) =>
  Eq (ConwayCertsPredFailure era)

deriving stock instance
  Show (PredicateFailure (EraRule "CERT" era)) =>
  Show (ConwayCertsPredFailure era)

instance
  NoThunks (PredicateFailure (EraRule "CERT" era)) =>
  NoThunks (ConwayCertsPredFailure era)

instance
  NFData (PredicateFailure (EraRule "CERT" era)) =>
  NFData (ConwayCertsPredFailure era)

newtype ConwayCertsEvent era = CertEvent (Event (EraRule "CERT" era))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
forall era x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
$cto :: forall era x. Rep (ConwayCertsEvent era) x -> ConwayCertsEvent era
$cfrom :: forall era x. ConwayCertsEvent era -> Rep (ConwayCertsEvent era) x
Generic)

deriving instance Eq (Event (EraRule "CERT" era)) => Eq (ConwayCertsEvent era)

instance NFData (Event (EraRule "CERT" era)) => NFData (ConwayCertsEvent era)

instance
  ( Era era
  , EncCBOR (PredicateFailure (EraRule "CERT" era))
  ) =>
  EncCBOR (ConwayCertsPredFailure era)
  where
  encCBOR :: ConwayCertsPredFailure era -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      WithdrawalsNotInRewardsCERTS Map (RewardAccount (EraCrypto era)) Coin
rs -> forall t. t -> Word -> Encode 'Open t
Sum (forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era) Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (RewardAccount (EraCrypto era)) Coin
rs
      CertFailure PredicateFailure (EraRule "CERT" era)
x -> forall t. t -> Word -> Encode 'Open t
Sum (forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure @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 PredicateFailure (EraRule "CERT" era)
x

instance
  ( Era era
  , DecCBOR (PredicateFailure (EraRule "CERT" era))
  ) =>
  DecCBOR (ConwayCertsPredFailure era)
  where
  decCBOR :: forall s. Decoder s (ConwayCertsPredFailure 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
"ConwayGovPredFailure" forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> forall t. t -> Decode 'Open t
SumD forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS 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
1 -> forall t. t -> Decode 'Open t
SumD forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure 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
k -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
k

instance
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraPParams era
  , State (EraRule "CERT" era) ~ CertState era
  , Signal (EraRule "CERT" era) ~ TxCert era
  , Environment (EraRule "CERT" era) ~ CertEnv era
  , Embed (EraRule "CERT" era) (ConwayCERTS era)
  ) =>
  STS (ConwayCERTS era)
  where
  type State (ConwayCERTS era) = CertState era
  type Signal (ConwayCERTS era) = Seq (TxCert era)
  type Environment (ConwayCERTS era) = CertsEnv era
  type BaseM (ConwayCERTS era) = ShelleyBase
  type
    PredicateFailure (ConwayCERTS era) =
      ConwayCertsPredFailure era
  type Event (ConwayCERTS era) = ConwayCertsEvent era

  transitionRules :: [TransitionRule (ConwayCERTS era)]
transitionRules = [forall era.
(EraTx era, ConwayEraTxBody era,
 State (EraRule "CERT" era) ~ CertState era,
 Embed (EraRule "CERT" era) (ConwayCERTS era),
 Environment (EraRule "CERT" era) ~ CertEnv era,
 Signal (EraRule "CERT" era) ~ TxCert era) =>
TransitionRule (ConwayCERTS era)
conwayCertsTransition @era]

conwayCertsTransition ::
  forall era.
  ( EraTx era
  , ConwayEraTxBody era
  , State (EraRule "CERT" era) ~ CertState era
  , Embed (EraRule "CERT" era) (ConwayCERTS era)
  , Environment (EraRule "CERT" era) ~ CertEnv era
  , Signal (EraRule "CERT" era) ~ TxCert era
  ) =>
  TransitionRule (ConwayCERTS era)
conwayCertsTransition :: forall era.
(EraTx era, ConwayEraTxBody era,
 State (EraRule "CERT" era) ~ CertState era,
 Embed (EraRule "CERT" era) (ConwayCERTS era),
 Environment (EraRule "CERT" era) ~ CertEnv era,
 Signal (EraRule "CERT" era) ~ TxCert era) =>
TransitionRule (ConwayCERTS era)
conwayCertsTransition = do
  TRC
    ( env :: Environment (ConwayCERTS era)
env@(CertsEnv Tx era
tx PParams era
pp SlotNo
slot EpochNo
currentEpoch StrictMaybe (Committee era)
committee Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
committeeProposals)
      , State (ConwayCERTS era)
certState
      , Signal (ConwayCERTS era)
certificates
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  Network
network <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Network
networkId

  case Signal (ConwayCERTS era)
certificates of
    Seq (TxCert era)
Signal (ConwayCERTS era)
Empty -> do
      let drepActivity :: EpochInterval
drepActivity = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL
      -- If there is a new governance proposal to vote on in this transaction,
      -- AND the number of dormant-epochs recorded is greater than zero, we bump
      -- the expiry for all DReps by the number of dormant epochs, and reset the
      -- counter to zero.
      -- It does not matter that this rule (CERTS) is called _before_ the GOV rule
      -- in LEDGER, even though we cannot validate any governance proposal here,
      -- since the entire transaction will fail if the proposal is not accepted in
      -- GOV, and so will this expiry bump done here. It will be discarded.
      let certState' :: CertState era
certState' =
            let hasProposals :: Bool
hasProposals = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OSet a -> Bool
OSet.null forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
             in if Bool
hasProposals
                  then State (ConwayCERTS era)
certState forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (VState era)
certVStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall era. EpochNo -> VState era -> VState era
updateDormantDRepExpiry EpochNo
currentEpoch
                  else State (ConwayCERTS era)
certState

      -- Update DRep expiry for all DReps that are voting in this transaction.
      -- This will execute in mutual-exclusion to the previous updates to DRep expiry,
      -- because if there are no proposals to vote on , there will be no votes either.
      let numDormantEpochs :: EpochNo
numDormantEpochs = CertState era
certState' forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL
          updateVSDReps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
updateVSDReps Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps =
            forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey'
              ( \Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps Voter (EraCrypto era)
voter Map (GovActionId (EraCrypto era)) (VotingProcedure era)
_ -> case Voter (EraCrypto era)
voter of
                  DRepVoter Credential 'DRepRole (EraCrypto era)
cred ->
                    forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
                      (forall c. Lens' (DRepState c) EpochNo
drepExpiryL forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry EpochInterval
drepActivity EpochNo
currentEpoch EpochNo
numDormantEpochs)
                      Credential 'DRepRole (EraCrypto era)
cred
                      Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps
                  Voter (EraCrypto era)
_ -> Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps
              )
              Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps
              (forall era.
VotingProcedures era
-> Map
     (Voter (EraCrypto era))
     (Map (GovActionId (EraCrypto era)) (VotingProcedure era))
unVotingProcedures forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL)

      -- Final CertState with updates to DRep expiry based on new proposals and votes on existing proposals
      let certStateWithDRepExpiryUpdated :: CertState era
certStateWithDRepExpiryUpdated = CertState era
certState' 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 -> (a -> b) -> s -> t
%~ Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
updateVSDReps
          dState :: DState era
dState = CertState era
certStateWithDRepExpiryUpdated forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (DState era)
certDStateL
          withdrawals :: Withdrawals (EraCrypto era)
withdrawals = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL

      -- Validate withdrawals and rewards and drain withdrawals
      forall e sts (ctx :: RuleType).
(e -> PredicateFailure sts)
-> Validation (NonEmpty e) () -> Rule sts ctx ()
validateTrans forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS forall a b. (a -> b) -> a -> b
$ forall era.
DState era
-> Withdrawals (EraCrypto era)
-> Network
-> Test (Map (RewardAccount (EraCrypto era)) Coin)
validateZeroRewards DState era
dState Withdrawals (EraCrypto era)
withdrawals Network
network

      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CertState era
certStateWithDRepExpiryUpdated forall a b. a -> (a -> b) -> b
& forall era. Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. DState era -> Withdrawals (EraCrypto era) -> DState era
drainWithdrawals DState era
dState Withdrawals (EraCrypto era)
withdrawals
    Seq (TxCert era)
gamma :|> TxCert era
txCert -> do
      CertState era
certState' <-
        forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(ConwayCERTS era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (ConwayCERTS era)
env, State (ConwayCERTS era)
certState, Seq (TxCert era)
gamma)
      forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "CERT" era) forall a b. (a -> b) -> a -> b
$
        forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era.
SlotNo
-> PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
-> CertEnv era
CertEnv SlotNo
slot PParams era
pp EpochNo
currentEpoch StrictMaybe (Committee era)
committee Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
committeeProposals, CertState era
certState', TxCert era
txCert)

instance
  ( Era era
  , STS (ConwayCERT era)
  , BaseM (EraRule "CERT" era) ~ ShelleyBase
  , Event (EraRule "CERT" era) ~ ConwayCertEvent era
  , PredicateFailure (EraRule "CERT" era) ~ ConwayCertPredFailure era
  ) =>
  Embed (ConwayCERT era) (ConwayCERTS era)
  where
  wrapFailed :: PredicateFailure (ConwayCERT era)
-> PredicateFailure (ConwayCERTS era)
wrapFailed = forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure
  wrapEvent :: Event (ConwayCERT era) -> Event (ConwayCERTS era)
wrapEvent = forall era. Event (EraRule "CERT" era) -> ConwayCertsEvent era
CertEvent

-- | Update dormant expiry for all DReps that are active.
-- And also reset the `numDormantEpochs` counter.
updateDormantDRepExpiry ::
  -- | Current Epoch
  EpochNo ->
  VState era ->
  VState era
updateDormantDRepExpiry :: forall era. EpochNo -> VState era -> VState era
updateDormantDRepExpiry EpochNo
currentEpoch VState era
vState =
  if EpochNo
numDormantEpochs forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0
    then VState era
vState
    else
      VState era
vState
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64 -> EpochNo
EpochNo Word64
0
        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 a b k. (a -> b) -> Map k a -> Map k b
Map.map DRepState (EraCrypto era) -> DRepState (EraCrypto era)
updateExpiry
  where
    numDormantEpochs :: EpochNo
numDormantEpochs = VState era
vState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL
    updateExpiry :: DRepState (EraCrypto era) -> DRepState (EraCrypto era)
updateExpiry =
      forall c. Lens' (DRepState c) EpochNo
drepExpiryL
        forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \EpochNo
currentExpiry ->
          let actualExpiry :: EpochNo
actualExpiry = (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo forall a. Num a => a -> a -> a
(+) EpochNo
numDormantEpochs EpochNo
currentExpiry
           in if EpochNo
actualExpiry forall a. Ord a => a -> a -> Bool
< EpochNo
currentEpoch
                then EpochNo
currentExpiry
                else EpochNo
actualExpiry