{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.GovCert (
  ConwayGOVCERT,
  ConwayGovCertPredFailure (..),
  ConwayGovCertEnv (..),
  computeDRepExpiry,
)
where

import Cardano.Ledger.BaseTypes (
  EpochNo,
  Mismatch (..),
  Relation (..),
  ShelleyBase,
  StrictMaybe,
  addEpochInterval,
  strictMaybe,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOVCERT)
import Cardano.Ledger.Conway.Governance (
  Committee (..),
  GovAction (..),
  GovActionPurpose (..),
  GovActionState (..),
  GovPurposeId,
  ProposalProcedure (..),
 )
import Cardano.Ledger.Conway.State (
  ConwayEraCertState (..),
  VState (..),
  csCommitteeCredsL,
  vsCommitteeStateL,
  vsDRepsL,
  vsNumDormantEpochsL,
 )
import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..))
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRepState (..), drepAnchorL, drepDepositL, drepExpiryL)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.State (
  CommitteeAuthorization (..),
  CommitteeState (..),
  EraCertState (..),
  dsUnifiedL,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Slotting.Slot (EpochInterval, binOpEpochNo)
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Control.State.Transition.Extended (
  BaseM,
  Environment,
  Event,
  PredicateFailure,
  STS,
  Signal,
  State,
  TRC (TRC),
  TransitionRule,
  failOnJust,
  judgmentContext,
  transitionRules,
  (?!),
 )
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Typeable (Typeable)
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (.~), (^.))
import NoThunks.Class (NoThunks (..))

data ConwayGovCertEnv era = ConwayGovCertEnv
  { forall era. ConwayGovCertEnv era -> PParams era
cgcePParams :: PParams era
  , forall era. ConwayGovCertEnv era -> EpochNo
cgceCurrentEpoch :: EpochNo
  -- ^ Lazy on purpose, because not all certificates need to know the current EpochNo
  , forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
  , forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
  -- ^ All of the `UpdateCommittee` proposals
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayGovCertEnv era) x -> ConwayGovCertEnv era
forall era x. ConwayGovCertEnv era -> Rep (ConwayGovCertEnv era) x
$cto :: forall era x. Rep (ConwayGovCertEnv era) x -> ConwayGovCertEnv era
$cfrom :: forall era x. ConwayGovCertEnv era -> Rep (ConwayGovCertEnv era) x
Generic)

instance EraPParams era => EncCBOR (ConwayGovCertEnv era) where
  encCBOR :: ConwayGovCertEnv era -> Encoding
encCBOR x :: ConwayGovCertEnv era
x@(ConwayGovCertEnv PParams era
_ EpochNo
_ StrictMaybe (Committee era)
_ Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
_) =
    let ConwayGovCertEnv {Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
PParams era
StrictMaybe (Committee era)
EpochNo
cgceCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
cgceCurrentEpoch :: EpochNo
cgcePParams :: PParams era
cgceCommitteeProposals :: forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCurrentCommittee :: forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentEpoch :: forall era. ConwayGovCertEnv era -> EpochNo
cgcePParams :: forall era. ConwayGovCertEnv era -> PParams era
..} = ConwayGovCertEnv era
x
     in forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
          forall t. t -> Encode ('Closed 'Dense) t
Rec forall era.
PParams era
-> EpochNo
-> StrictMaybe (Committee era)
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
-> ConwayGovCertEnv era
ConwayGovCertEnv
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
cgcePParams
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
cgceCurrentEpoch
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe (Committee era)
cgceCurrentCommittee
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals

instance EraPParams era => NFData (ConwayGovCertEnv era)

deriving instance EraPParams era => Show (ConwayGovCertEnv era)

deriving instance EraPParams era => Eq (ConwayGovCertEnv era)

data ConwayGovCertPredFailure era
  = ConwayDRepAlreadyRegistered (Credential 'DRepRole)
  | ConwayDRepNotRegistered (Credential 'DRepRole)
  | ConwayDRepIncorrectDeposit (Mismatch 'RelEQ Coin)
  | ConwayCommitteeHasPreviouslyResigned (Credential 'ColdCommitteeRole)
  | ConwayDRepIncorrectRefund (Mismatch 'RelEQ Coin)
  | -- | Predicate failure whenever an update to an unknown committee member is
    -- attempted. Current Constitutional Committee and all available proposals will be
    -- searched before reporting this predicate failure.
    ConwayCommitteeIsUnknown (Credential 'ColdCommitteeRole)
  deriving (Int -> ConwayGovCertPredFailure era -> ShowS
forall era. Int -> ConwayGovCertPredFailure era -> ShowS
forall era. [ConwayGovCertPredFailure era] -> ShowS
forall era. ConwayGovCertPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayGovCertPredFailure era] -> ShowS
$cshowList :: forall era. [ConwayGovCertPredFailure era] -> ShowS
show :: ConwayGovCertPredFailure era -> String
$cshow :: forall era. ConwayGovCertPredFailure era -> String
showsPrec :: Int -> ConwayGovCertPredFailure era -> ShowS
$cshowsPrec :: forall era. Int -> ConwayGovCertPredFailure era -> ShowS
Show, ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
$c/= :: forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
== :: ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
$c== :: forall era.
ConwayGovCertPredFailure era
-> ConwayGovCertPredFailure era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayGovCertPredFailure era) x
-> ConwayGovCertPredFailure era
forall era x.
ConwayGovCertPredFailure era
-> Rep (ConwayGovCertPredFailure era) x
$cto :: forall era x.
Rep (ConwayGovCertPredFailure era) x
-> ConwayGovCertPredFailure era
$cfrom :: forall era x.
ConwayGovCertPredFailure era
-> Rep (ConwayGovCertPredFailure era) x
Generic)

type instance EraRuleFailure "GOVCERT" ConwayEra = ConwayGovCertPredFailure ConwayEra

type instance EraRuleEvent "GOVCERT" ConwayEra = VoidEraRule "GOVCERT" ConwayEra

instance InjectRuleFailure "GOVCERT" ConwayGovCertPredFailure ConwayEra

instance NoThunks (ConwayGovCertPredFailure era)

instance NFData (ConwayGovCertPredFailure era)

instance Era era => EncCBOR (ConwayGovCertPredFailure era) where
  encCBOR :: ConwayGovCertPredFailure era -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode @_ @(ConwayGovCertPredFailure era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      ConwayDRepAlreadyRegistered Credential 'DRepRole
cred -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'DRepRole
cred
      ConwayDRepNotRegistered Credential 'DRepRole
cred -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'DRepRole
cred
      ConwayDRepIncorrectDeposit Mismatch 'RelEQ Coin
mm -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBORGroup t => t -> Encode ('Closed 'Dense) t
ToGroup Mismatch 'RelEQ Coin
mm
      ConwayCommitteeHasPreviouslyResigned Credential 'ColdCommitteeRole
coldCred -> forall t. t -> Word -> Encode 'Open t
Sum forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned Word
3 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'ColdCommitteeRole
coldCred
      ConwayDRepIncorrectRefund Mismatch 'RelEQ Coin
mm -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund Word
4 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBORGroup t => t -> Encode ('Closed 'Dense) t
ToGroup Mismatch 'RelEQ Coin
mm
      ConwayCommitteeIsUnknown Credential 'ColdCommitteeRole
coldCred -> forall t. t -> Word -> Encode 'Open t
Sum forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown Word
5 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Credential 'ColdCommitteeRole
coldCred

instance Typeable era => DecCBOR (ConwayGovCertPredFailure era) where
  decCBOR :: forall s. Decoder s (ConwayGovCertPredFailure era)
decCBOR = forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ConwayGovCertPredFailure" forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> forall t. t -> Decode 'Open t
SumD forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
1 -> forall t. t -> Decode 'Open t
SumD forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> forall t. t -> Decode 'Open t
SumD forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped).
(EncCBORGroup t, DecCBORGroup t) =>
Decode w t
FromGroup
    Word
3 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
4 -> forall t. t -> Decode 'Open t
SumD forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped).
(EncCBORGroup t, DecCBORGroup t) =>
Decode w t
FromGroup
    Word
5 -> forall t. t -> Decode 'Open t
SumD forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance
  ( ConwayEraPParams era
  , State (EraRule "GOVCERT" era) ~ CertState era
  , Signal (EraRule "GOVCERT" era) ~ ConwayGovCert
  , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
  , EraRule "GOVCERT" era ~ ConwayGOVCERT era
  , Eq (PredicateFailure (EraRule "GOVCERT" era))
  , Show (PredicateFailure (EraRule "GOVCERT" era))
  , ConwayEraCertState era
  ) =>
  STS (ConwayGOVCERT era)
  where
  type State (ConwayGOVCERT era) = CertState era
  type Signal (ConwayGOVCERT era) = ConwayGovCert
  type Environment (ConwayGOVCERT era) = ConwayGovCertEnv era
  type BaseM (ConwayGOVCERT era) = ShelleyBase
  type PredicateFailure (ConwayGOVCERT era) = ConwayGovCertPredFailure era
  type Event (ConwayGOVCERT era) = Void

  transitionRules :: [TransitionRule (ConwayGOVCERT era)]
transitionRules = [forall era.
(ConwayEraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition @era]

conwayGovCertTransition ::
  ( ConwayEraPParams era
  , ConwayEraCertState era
  ) =>
  TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition :: forall era.
(ConwayEraPParams era, ConwayEraCertState era) =>
TransitionRule (ConwayGOVCERT era)
conwayGovCertTransition = do
  TRC
    ( ConwayGovCertEnv {PParams era
cgcePParams :: PParams era
cgcePParams :: forall era. ConwayGovCertEnv era -> PParams era
cgcePParams, EpochNo
cgceCurrentEpoch :: EpochNo
cgceCurrentEpoch :: forall era. ConwayGovCertEnv era -> EpochNo
cgceCurrentEpoch, StrictMaybe (Committee era)
cgceCurrentCommittee :: StrictMaybe (Committee era)
cgceCurrentCommittee :: forall era. ConwayGovCertEnv era -> StrictMaybe (Committee era)
cgceCurrentCommittee, Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals :: forall era.
ConwayGovCertEnv era
-> Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals}
      , State (ConwayGOVCERT era)
certState
      , Signal (ConwayGOVCERT era)
cert
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let ppDRepDeposit :: Coin
ppDRepDeposit = PParams era
cgcePParams forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL
      ppDRepActivity :: EpochInterval
ppDRepActivity = PParams era
cgcePParams forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL
      checkAndOverwriteCommitteeMemberState :: Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred CommitteeAuthorization
newMemberState = do
        let VState {vsCommitteeState :: forall era. VState era -> CommitteeState era
vsCommitteeState = CommitteeState Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds} = State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL
            coldCredResigned :: Maybe (Credential 'ColdCommitteeRole)
coldCredResigned =
              forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldCred Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                CommitteeMemberResigned {} -> forall a. a -> Maybe a
Just Credential 'ColdCommitteeRole
coldCred
                CommitteeHotCredential {} -> forall a. Maybe a
Nothing
        forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe (Credential 'ColdCommitteeRole)
coldCredResigned forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeHasPreviouslyResigned
        let isCurrentMember :: Bool
isCurrentMember =
              forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe Bool
False (forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole
coldCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers) StrictMaybe (Committee era)
cgceCurrentCommittee
            committeeUpdateContainsColdCred :: GovActionState era -> Bool
committeeUpdateContainsColdCred GovActionState {ProposalProcedure era
gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure} =
              case forall era. ProposalProcedure era -> GovAction era
pProcGovAction ProposalProcedure era
gasProposalProcedure of
                UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
_ Set (Credential 'ColdCommitteeRole)
_ Map (Credential 'ColdCommitteeRole) EpochNo
newMembers UnitInterval
_ -> forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole
coldCred Map (Credential 'ColdCommitteeRole) EpochNo
newMembers
                GovAction era
_ -> Bool
False
            isPotentialFutureMember :: Bool
isPotentialFutureMember =
              forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GovActionState era -> Bool
committeeUpdateContainsColdCred Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
cgceCommitteeProposals
        Bool
isCurrentMember Bool -> Bool -> Bool
|| Bool
isPotentialFutureMember forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Credential 'ColdCommitteeRole -> ConwayGovCertPredFailure era
ConwayCommitteeIsUnknown Credential 'ColdCommitteeRole
coldCred
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          State (ConwayGOVCERT era)
certState
            forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (CommitteeState era)
  (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'ColdCommitteeRole
coldCred CommitteeAuthorization
newMemberState
  case Signal (ConwayGOVCERT era)
cert of
    ConwayRegDRep Credential 'DRepRole
cred Coin
deposit StrictMaybe Anchor
mAnchor -> do
      forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepAlreadyRegistered Credential 'DRepRole
cred
      Coin
deposit
        forall a. Eq a => a -> a -> Bool
== Coin
ppDRepDeposit
          forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectDeposit
            Mismatch
              { mismatchSupplied :: Coin
mismatchSupplied = Coin
deposit
              , mismatchExpected :: Coin
mismatchExpected = Coin
ppDRepDeposit
              }
      let drepState :: DRepState
drepState =
            DRepState
              { drepExpiry :: EpochNo
drepExpiry =
                  forall era.
ConwayEraPParams era =>
PParams era -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiryVersioned
                    PParams era
cgcePParams
                    EpochNo
cgceCurrentEpoch
                    (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL)
              , drepAnchor :: StrictMaybe Anchor
drepAnchor = StrictMaybe Anchor
mAnchor
              , drepDeposit :: Coin
drepDeposit = Coin
ppDRepDeposit
              , drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Monoid a => a
mempty
              }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        State (ConwayGOVCERT era)
certState
          forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole
cred DRepState
drepState
    ConwayUnRegDRep Credential 'DRepRole
cred Coin
refund -> do
      let mDRepState :: Maybe DRepState
mDRepState = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL)
          drepRefundMismatch :: Maybe Coin
drepRefundMismatch = do
            DRepState
drepState <- Maybe DRepState
mDRepState
            let paidDeposit :: Coin
paidDeposit = DRepState
drepState forall s a. s -> Getting a s a -> a
^. Lens' DRepState Coin
drepDepositL
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Coin
refund forall a. Eq a => a -> a -> Bool
/= Coin
paidDeposit)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
paidDeposit
      forall a. Maybe a -> Bool
isJust Maybe DRepState
mDRepState forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Credential 'DRepRole
cred
      forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe Coin
drepRefundMismatch forall a b. (a -> b) -> a -> b
$ forall era. Mismatch 'RelEQ Coin -> ConwayGovCertPredFailure era
ConwayDRepIncorrectRefund forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
refund
      let
        certState' :: CertState era
certState' =
          State (ConwayGOVCERT era)
certState forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Credential 'DRepRole
cred
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        case Maybe DRepState
mDRepState of
          Maybe DRepState
Nothing -> CertState era
certState'
          Just DRepState
dRepState ->
            CertState era
certState'
              forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepState -> Set (Credential 'Staking)
drepDelegs DRepState
dRepState forall k v. Set k -> UView k v -> UMap
UM.⋪ UMap -> UView (Credential 'Staking) DRep
UM.DRepUView (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL)
    -- Update a DRep expiry along with its anchor.
    ConwayUpdateDRep Credential 'DRepRole
cred StrictMaybe Anchor
mAnchor -> do
      forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'DRepRole
cred (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Credential 'DRepRole -> ConwayGovCertPredFailure era
ConwayDRepNotRegistered Credential 'DRepRole
cred
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        State (ConwayGOVCERT era)
certState
          forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
            forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
                  ( \DRepState
drepState ->
                      DRepState
drepState
                        forall a b. a -> (a -> b) -> b
& Lens' DRepState EpochNo
drepExpiryL
                          forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry
                            EpochInterval
ppDRepActivity
                            EpochNo
cgceCurrentEpoch
                            (State (ConwayGOVCERT era)
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL)
                        forall a b. a -> (a -> b) -> b
& Lens' DRepState (StrictMaybe Anchor)
drepAnchorL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe Anchor
mAnchor
                  )
                  Credential 'DRepRole
cred
               )
    ConwayAuthCommitteeHotKey Credential 'ColdCommitteeRole
coldCred Credential 'HotCommitteeRole
hotCred ->
      Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred forall a b. (a -> b) -> a -> b
$ Credential 'HotCommitteeRole -> CommitteeAuthorization
CommitteeHotCredential Credential 'HotCommitteeRole
hotCred
    ConwayResignCommitteeColdKey Credential 'ColdCommitteeRole
coldCred StrictMaybe Anchor
anchor ->
      Credential 'ColdCommitteeRole
-> CommitteeAuthorization
-> F (Clause (ConwayGOVCERT era) 'Transition) (CertState era)
checkAndOverwriteCommitteeMemberState Credential 'ColdCommitteeRole
coldCred forall a b. (a -> b) -> a -> b
$ StrictMaybe Anchor -> CommitteeAuthorization
CommitteeMemberResigned StrictMaybe Anchor
anchor

computeDRepExpiryVersioned ::
  ConwayEraPParams era =>
  PParams era ->
  -- | Current epoch
  EpochNo ->
  -- | The count of the dormant epochs
  EpochNo ->
  EpochNo
computeDRepExpiryVersioned :: forall era.
ConwayEraPParams era =>
PParams era -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiryVersioned PParams era
pp EpochNo
currentEpoch EpochNo
numDormantEpochs
  -- Starting with version 10, we correctly take into account the number of dormant epochs
  -- when registering a drep
  | ProtVer -> Bool
HF.bootstrapPhase (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL) =
      EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL)
  | Bool
otherwise =
      EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL) EpochNo
currentEpoch EpochNo
numDormantEpochs

computeDRepExpiry ::
  -- | DRepActivity PParam
  EpochInterval ->
  -- | Current epoch
  EpochNo ->
  -- | The count of the dormant epochs
  EpochNo ->
  -- | Computed expiry
  EpochNo
computeDRepExpiry :: EpochInterval -> EpochNo -> EpochNo -> EpochNo
computeDRepExpiry EpochInterval
ppDRepActivity EpochNo
currentEpoch =
  (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo
    (-)
    (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
ppDRepActivity)