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

module Cardano.Ledger.Conway.Rules.Gov (
  ConwayGOV,
  GovEnv (..),
  GovSignal (..),
  ConwayGovEvent (..),
  ConwayGovPredFailure (..),
) where

import Cardano.Ledger.Address (RewardAccount, raCredential, raNetwork)
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  Mismatch (..),
  Network,
  ProtVer,
  Relation (..),
  ShelleyBase,
  StrictMaybe (SJust),
  addEpochInterval,
  networkId,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
 )
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.CertState (
  CertState (..),
  CommitteeState (..),
  PState (..),
  VState (..),
  authorizedHotCommitteeCredentials,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core (ppGovActionDepositL, ppGovActionLifetimeL)
import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOV)
import Cardano.Ledger.Conway.Governance (
  GovAction (..),
  GovActionId (..),
  GovActionPurpose (..),
  GovActionState (..),
  GovPurposeId (..),
  GovRelation (..),
  ProposalProcedure (..),
  Proposals,
  Voter (..),
  VotingProcedure (..),
  VotingProcedures (..),
  foldlVotingProcedures,
  foldrVotingProcedures,
  gasAction,
  gasDRepVotesL,
  grHardForkL,
  indexedGovProps,
  isCommitteeVotingAllowed,
  isDRepVotingAllowed,
  isStakePoolVotingAllowed,
  pProcGovActionL,
  pProcReturnAddrL,
  pRootsL,
  proposalsActionsMap,
  proposalsAddAction,
  proposalsAddVote,
  proposalsLookupId,
  toPrevGovActionIds,
 )
import Cardano.Ledger.Conway.Governance.Proposals (mapProposals)
import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Rules.ValidationMode (Test, runTest)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState (dsUnifiedL)
import Cardano.Ledger.Shelley.PParams (pvCanFollow)
import Cardano.Ledger.TxIn (TxId (..))
import qualified Cardano.Ledger.UMap as UMap
import Control.DeepSeq (NFData)
import Control.Monad (unless)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended (
  STS (..),
  TRC (..),
  TransitionRule,
  failBecause,
  failOnJust,
  failOnNonEmpty,
  failureOnNonEmpty,
  judgmentContext,
  liftSTS,
  tellEvent,
  (?!),
 )
import qualified Data.Foldable as F
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import Data.Pulse (foldlM')
import qualified Data.Sequence.Strict as SSeq
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro
import qualified Lens.Micro as L
import NoThunks.Class (NoThunks (..))
import Validation (failureUnless)

data GovEnv era = GovEnv
  { forall era. GovEnv era -> TxId
geTxId :: !TxId
  , forall era. GovEnv era -> EpochNo
geEpoch :: !EpochNo
  , forall era. GovEnv era -> PParams era
gePParams :: !(PParams era)
  , forall era. GovEnv era -> StrictMaybe ScriptHash
gePPolicy :: !(StrictMaybe ScriptHash)
  , forall era. GovEnv era -> CertState era
geCertState :: !(CertState era)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (GovEnv era) x -> GovEnv era
forall era x. GovEnv era -> Rep (GovEnv era) x
$cto :: forall era x. Rep (GovEnv era) x -> GovEnv era
$cfrom :: forall era x. GovEnv era -> Rep (GovEnv era) x
Generic)

instance EraPParams era => EncCBOR (GovEnv era) where
  encCBOR :: GovEnv era -> Encoding
encCBOR x :: GovEnv era
x@(GovEnv TxId
_ EpochNo
_ PParams era
_ StrictMaybe ScriptHash
_ CertState era
_) =
    let GovEnv {PParams era
StrictMaybe ScriptHash
CertState era
TxId
EpochNo
geCertState :: CertState era
gePPolicy :: StrictMaybe ScriptHash
gePParams :: PParams era
geEpoch :: EpochNo
geTxId :: TxId
geCertState :: forall era. GovEnv era -> CertState era
gePPolicy :: forall era. GovEnv era -> StrictMaybe ScriptHash
gePParams :: forall era. GovEnv era -> PParams era
geEpoch :: forall era. GovEnv era -> EpochNo
geTxId :: forall era. GovEnv era -> TxId
..} = GovEnv 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.
TxId
-> EpochNo
-> PParams era
-> StrictMaybe ScriptHash
-> CertState era
-> GovEnv era
GovEnv
            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 TxId
geTxId
            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
geEpoch
            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
gePParams
            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 ScriptHash
gePPolicy
            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 CertState era
geCertState

instance (NFData (PParams era), Era era) => NFData (GovEnv era)
deriving instance (Show (PParams era), Era era) => Show (GovEnv era)
deriving instance Eq (PParams era) => Eq (GovEnv era)

data ConwayGovPredFailure era
  = GovActionsDoNotExist (NonEmpty GovActionId)
  | MalformedProposal (GovAction era)
  | ProposalProcedureNetworkIdMismatch RewardAccount Network
  | TreasuryWithdrawalsNetworkIdMismatch (Set.Set RewardAccount) Network
  | ProposalDepositIncorrect !(Mismatch 'RelEQ Coin)
  | -- | Some governance actions are not allowed to be voted on by certain types of
    -- Voters. This failure lists all governance action ids with their respective voters
    -- that are not allowed to vote on those governance actions.
    DisallowedVoters !(NonEmpty (Voter, GovActionId))
  | ConflictingCommitteeUpdate
      -- | Credentials that are mentioned as members to be both removed and added
      (Set.Set (Credential 'ColdCommitteeRole))
  | ExpirationEpochTooSmall
      -- | Members for which the expiration epoch has already been reached
      (Map.Map (Credential 'ColdCommitteeRole) EpochNo)
  | InvalidPrevGovActionId (ProposalProcedure era)
  | VotingOnExpiredGovAction (NonEmpty (Voter, GovActionId))
  | ProposalCantFollow
      -- | The PrevGovActionId of the HardForkInitiation that fails
      (StrictMaybe (GovPurposeId 'HardForkPurpose era))
      -- | Its protocol version and the protocal version of the previous gov-action pointed to by the proposal
      !(Mismatch 'RelGT ProtVer)
  | InvalidPolicyHash
      -- | The policy script hash in the proposal
      (StrictMaybe ScriptHash)
      -- | The policy script hash of the current constitution
      (StrictMaybe ScriptHash)
  | DisallowedProposalDuringBootstrap (ProposalProcedure era)
  | DisallowedVotesDuringBootstrap
      (NonEmpty (Voter, GovActionId))
  | -- | Predicate failure for votes by entities that are not present in the ledger state
    VotersDoNotExist (NonEmpty Voter)
  | -- | Treasury withdrawals that sum up to zero are not allowed
    ZeroTreasuryWithdrawals (GovAction era)
  | -- | Proposals that have an invalid reward account for returns of the deposit
    ProposalReturnAccountDoesNotExist RewardAccount
  | -- | Treasury withdrawal proposals to an invalid reward account
    TreasuryWithdrawalReturnAccountsDoNotExist (NonEmpty RewardAccount)
  deriving (ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
forall era.
EraPParams era =>
ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
$c/= :: forall era.
EraPParams era =>
ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
== :: ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
$c== :: forall era.
EraPParams era =>
ConwayGovPredFailure era -> ConwayGovPredFailure era -> Bool
Eq, Int -> ConwayGovPredFailure era -> ShowS
forall era.
EraPParams era =>
Int -> ConwayGovPredFailure era -> ShowS
forall era. EraPParams era => [ConwayGovPredFailure era] -> ShowS
forall era. EraPParams era => ConwayGovPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayGovPredFailure era] -> ShowS
$cshowList :: forall era. EraPParams era => [ConwayGovPredFailure era] -> ShowS
show :: ConwayGovPredFailure era -> String
$cshow :: forall era. EraPParams era => ConwayGovPredFailure era -> String
showsPrec :: Int -> ConwayGovPredFailure era -> ShowS
$cshowsPrec :: forall era.
EraPParams era =>
Int -> ConwayGovPredFailure era -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayGovPredFailure era) x -> ConwayGovPredFailure era
forall era x.
ConwayGovPredFailure era -> Rep (ConwayGovPredFailure era) x
$cto :: forall era x.
Rep (ConwayGovPredFailure era) x -> ConwayGovPredFailure era
$cfrom :: forall era x.
ConwayGovPredFailure era -> Rep (ConwayGovPredFailure era) x
Generic)

type instance EraRuleFailure "GOV" ConwayEra = ConwayGovPredFailure ConwayEra

type instance EraRuleEvent "GOV" ConwayEra = ConwayGovEvent ConwayEra

instance InjectRuleFailure "GOV" ConwayGovPredFailure ConwayEra

instance EraPParams era => NFData (ConwayGovPredFailure era)

instance EraPParams era => NoThunks (ConwayGovPredFailure era)

instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where
  decCBOR :: forall s. Decoder s (ConwayGovPredFailure 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. NonEmpty GovActionId -> ConwayGovPredFailure era
GovActionsDoNotExist 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. GovAction era -> ConwayGovPredFailure era
MalformedProposal 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. RewardAccount -> Network -> ConwayGovPredFailure era
ProposalProcedureNetworkIdMismatch 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 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.
Set RewardAccount -> Network -> ConwayGovPredFailure era
TreasuryWithdrawalsNetworkIdMismatch 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 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. Mismatch 'RelEQ Coin -> ConwayGovPredFailure era
ProposalDepositIncorrect forall (w1 :: Wrapped) a t (w :: Density).
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.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVoters 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.
Set (Credential 'ColdCommitteeRole) -> ConwayGovPredFailure era
ConflictingCommitteeUpdate 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
7 -> forall t. t -> Decode 'Open t
SumD forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> ConwayGovPredFailure era
ExpirationEpochTooSmall 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
8 -> forall t. t -> Decode 'Open t
SumD forall era. ProposalProcedure era -> ConwayGovPredFailure era
InvalidPrevGovActionId 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
9 -> forall t. t -> Decode 'Open t
SumD forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
VotingOnExpiredGovAction 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
10 -> forall t. t -> Decode 'Open t
SumD forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> Mismatch 'RelGT ProtVer -> ConwayGovPredFailure era
ProposalCantFollow 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 forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped).
(EncCBORGroup t, DecCBORGroup t) =>
Decode w t
FromGroup
    Word
11 -> forall t. t -> Decode 'Open t
SumD forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> ConwayGovPredFailure era
InvalidPolicyHash 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 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
12 -> forall t. t -> Decode 'Open t
SumD forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap 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
13 -> forall t. t -> Decode 'Open t
SumD forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVotesDuringBootstrap 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
14 -> forall t. t -> Decode 'Open t
SumD forall era. NonEmpty Voter -> ConwayGovPredFailure era
VotersDoNotExist 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
15 -> forall t. t -> Decode 'Open t
SumD forall era. GovAction era -> ConwayGovPredFailure era
ZeroTreasuryWithdrawals 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
16 -> forall t. t -> Decode 'Open t
SumD forall era. RewardAccount -> ConwayGovPredFailure era
ProposalReturnAccountDoesNotExist 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
17 -> forall t. t -> Decode 'Open t
SumD forall era. NonEmpty RewardAccount -> ConwayGovPredFailure era
TreasuryWithdrawalReturnAccountsDoNotExist 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 EraPParams era => EncCBOR (ConwayGovPredFailure era) where
  encCBOR :: ConwayGovPredFailure era -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      GovActionsDoNotExist NonEmpty GovActionId
gid ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. NonEmpty GovActionId -> ConwayGovPredFailure era
GovActionsDoNotExist 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 NonEmpty GovActionId
gid
      MalformedProposal GovAction era
ga ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. GovAction era -> ConwayGovPredFailure era
MalformedProposal 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 GovAction era
ga
      ProposalProcedureNetworkIdMismatch RewardAccount
acnt Network
nid ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. RewardAccount -> Network -> ConwayGovPredFailure era
ProposalProcedureNetworkIdMismatch 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 RewardAccount
acnt 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 Network
nid
      TreasuryWithdrawalsNetworkIdMismatch Set RewardAccount
acnts Network
nid ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
Set RewardAccount -> Network -> ConwayGovPredFailure era
TreasuryWithdrawalsNetworkIdMismatch 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 Set RewardAccount
acnts 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 Network
nid
      ProposalDepositIncorrect Mismatch 'RelEQ Coin
mm ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. Mismatch 'RelEQ Coin -> ConwayGovPredFailure era
ProposalDepositIncorrect 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
      DisallowedVoters NonEmpty (Voter, GovActionId)
votes ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVoters 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 NonEmpty (Voter, GovActionId)
votes
      ConflictingCommitteeUpdate Set (Credential 'ColdCommitteeRole)
members ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
Set (Credential 'ColdCommitteeRole) -> ConwayGovPredFailure era
ConflictingCommitteeUpdate 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 Set (Credential 'ColdCommitteeRole)
members
      ExpirationEpochTooSmall Map (Credential 'ColdCommitteeRole) EpochNo
members ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> ConwayGovPredFailure era
ExpirationEpochTooSmall Word
7 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 (Credential 'ColdCommitteeRole) EpochNo
members
      InvalidPrevGovActionId ProposalProcedure era
proposal ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. ProposalProcedure era -> ConwayGovPredFailure era
InvalidPrevGovActionId Word
8 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 ProposalProcedure era
proposal
      VotingOnExpiredGovAction NonEmpty (Voter, GovActionId)
ga ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
VotingOnExpiredGovAction Word
9 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 NonEmpty (Voter, GovActionId)
ga
      ProposalCantFollow StrictMaybe (GovPurposeId 'HardForkPurpose era)
prevgaid Mismatch 'RelGT ProtVer
mm ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> Mismatch 'RelGT ProtVer -> ConwayGovPredFailure era
ProposalCantFollow Word
10 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 (GovPurposeId 'HardForkPurpose era)
prevgaid 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 'RelGT ProtVer
mm
      InvalidPolicyHash StrictMaybe ScriptHash
got StrictMaybe ScriptHash
expected ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> ConwayGovPredFailure era
InvalidPolicyHash Word
11 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 ScriptHash
got 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 ScriptHash
expected
      DisallowedProposalDuringBootstrap ProposalProcedure era
proposal ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap Word
12 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 ProposalProcedure era
proposal
      DisallowedVotesDuringBootstrap NonEmpty (Voter, GovActionId)
votes ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVotesDuringBootstrap Word
13 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 NonEmpty (Voter, GovActionId)
votes
      VotersDoNotExist NonEmpty Voter
voters ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. NonEmpty Voter -> ConwayGovPredFailure era
VotersDoNotExist Word
14 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 NonEmpty Voter
voters
      ZeroTreasuryWithdrawals GovAction era
ga ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. GovAction era -> ConwayGovPredFailure era
ZeroTreasuryWithdrawals Word
15 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 GovAction era
ga
      ProposalReturnAccountDoesNotExist RewardAccount
returnAccount ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. RewardAccount -> ConwayGovPredFailure era
ProposalReturnAccountDoesNotExist Word
16 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 RewardAccount
returnAccount
      TreasuryWithdrawalReturnAccountsDoNotExist NonEmpty RewardAccount
accounts ->
        forall t. t -> Word -> Encode 'Open t
Sum forall era. NonEmpty RewardAccount -> ConwayGovPredFailure era
TreasuryWithdrawalReturnAccountsDoNotExist Word
17 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 NonEmpty RewardAccount
accounts

instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
  toCBOR :: ConwayGovPredFailure era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance EraPParams era => FromCBOR (ConwayGovPredFailure era) where
  fromCBOR :: forall s. Decoder s (ConwayGovPredFailure era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

data ConwayGovEvent era
  = GovNewProposals !TxId !(Proposals era)
  | GovRemovedVotes
      !TxId
      -- | Votes that were replaced in this tx.
      !(Set (Voter, GovActionId))
      -- | Any votes from these DReps in this or in previous txs are removed
      !(Set (Credential 'DRepRole))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayGovEvent era) x -> ConwayGovEvent era
forall era x. ConwayGovEvent era -> Rep (ConwayGovEvent era) x
$cto :: forall era x. Rep (ConwayGovEvent era) x -> ConwayGovEvent era
$cfrom :: forall era x. ConwayGovEvent era -> Rep (ConwayGovEvent era) x
Generic, ConwayGovEvent era -> ConwayGovEvent era -> Bool
forall era.
EraPParams era =>
ConwayGovEvent era -> ConwayGovEvent era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayGovEvent era -> ConwayGovEvent era -> Bool
$c/= :: forall era.
EraPParams era =>
ConwayGovEvent era -> ConwayGovEvent era -> Bool
== :: ConwayGovEvent era -> ConwayGovEvent era -> Bool
$c== :: forall era.
EraPParams era =>
ConwayGovEvent era -> ConwayGovEvent era -> Bool
Eq)

instance EraPParams era => NFData (ConwayGovEvent era)

data GovSignal era = GovSignal
  { forall era. GovSignal era -> VotingProcedures era
gsVotingProcedures :: !(VotingProcedures era)
  , forall era. GovSignal era -> OSet (ProposalProcedure era)
gsProposalProcedures :: !(OSet.OSet (ProposalProcedure era))
  , forall era. GovSignal era -> StrictSeq (TxCert era)
gsCertificates :: !(SSeq.StrictSeq (TxCert era))
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (GovSignal era) x -> GovSignal era
forall era x. GovSignal era -> Rep (GovSignal era) x
$cto :: forall era x. Rep (GovSignal era) x -> GovSignal era
$cfrom :: forall era x. GovSignal era -> Rep (GovSignal era) x
Generic)

instance (EraPParams era, EraTxCert era) => EncCBOR (GovSignal era) where
  encCBOR :: GovSignal era -> Encoding
encCBOR x :: GovSignal era
x@(GovSignal VotingProcedures era
_ OSet (ProposalProcedure era)
_ StrictSeq (TxCert era)
_) =
    let GovSignal {OSet (ProposalProcedure era)
StrictSeq (TxCert era)
VotingProcedures era
gsCertificates :: StrictSeq (TxCert era)
gsProposalProcedures :: OSet (ProposalProcedure era)
gsVotingProcedures :: VotingProcedures era
gsCertificates :: forall era. GovSignal era -> StrictSeq (TxCert era)
gsProposalProcedures :: forall era. GovSignal era -> OSet (ProposalProcedure era)
gsVotingProcedures :: forall era. GovSignal era -> VotingProcedures era
..} = GovSignal 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.
VotingProcedures era
-> OSet (ProposalProcedure era)
-> StrictSeq (TxCert era)
-> GovSignal era
GovSignal
            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 VotingProcedures era
gsVotingProcedures
            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 OSet (ProposalProcedure era)
gsProposalProcedures
            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 StrictSeq (TxCert era)
gsCertificates
deriving instance (EraPParams era, Eq (TxCert era)) => Eq (GovSignal era)
deriving instance (EraPParams era, Show (TxCert era)) => Show (GovSignal era)

instance (EraPParams era, NFData (TxCert era)) => NFData (GovSignal era)

instance
  ( ConwayEraTxCert era
  , ConwayEraPParams era
  , EraRule "GOV" era ~ ConwayGOV era
  , InjectRuleFailure "GOV" ConwayGovPredFailure era
  ) =>
  STS (ConwayGOV era)
  where
  type State (ConwayGOV era) = Proposals era
  type Signal (ConwayGOV era) = GovSignal era
  type Environment (ConwayGOV era) = GovEnv era
  type BaseM (ConwayGOV era) = ShelleyBase
  type PredicateFailure (ConwayGOV era) = ConwayGovPredFailure era
  type Event (ConwayGOV era) = ConwayGovEvent era

  initialRules :: [InitialRule (ConwayGOV era)]
initialRules = []

  transitionRules :: [TransitionRule (ConwayGOV era)]
transitionRules = [forall era.
(ConwayEraTxCert era, ConwayEraPParams era,
 STS (EraRule "GOV" era),
 Event (EraRule "GOV" era) ~ ConwayGovEvent era,
 Signal (EraRule "GOV" era) ~ GovSignal era,
 PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era,
 BaseM (EraRule "GOV" era) ~ ShelleyBase,
 Environment (EraRule "GOV" era) ~ GovEnv era,
 State (EraRule "GOV" era) ~ Proposals era,
 InjectRuleFailure "GOV" ConwayGovPredFailure era) =>
TransitionRule (EraRule "GOV" era)
govTransition @era]

checkVotesAreNotForExpiredActions ::
  EpochNo ->
  [(Voter, GovActionState era)] ->
  Test (ConwayGovPredFailure era)
checkVotesAreNotForExpiredActions :: forall era.
EpochNo
-> [(Voter, GovActionState era)] -> Test (ConwayGovPredFailure era)
checkVotesAreNotForExpiredActions EpochNo
curEpoch [(Voter, GovActionState era)]
votes =
  forall era.
[(Voter, GovActionState era)]
-> (NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era)
-> (GovActionState era -> Voter -> Bool)
-> Test (ConwayGovPredFailure era)
checkDisallowedVotes [(Voter, GovActionState era)]
votes forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
VotingOnExpiredGovAction forall a b. (a -> b) -> a -> b
$ \GovActionState {EpochNo
gasExpiresAfter :: forall era. GovActionState era -> EpochNo
gasExpiresAfter :: EpochNo
gasExpiresAfter} Voter
_ ->
    EpochNo
curEpoch forall a. Ord a => a -> a -> Bool
<= EpochNo
gasExpiresAfter

checkVotersAreValid ::
  forall era.
  ConwayEraPParams era =>
  EpochNo ->
  CommitteeState era ->
  [(Voter, GovActionState era)] ->
  Test (ConwayGovPredFailure era)
checkVotersAreValid :: forall era.
ConwayEraPParams era =>
EpochNo
-> CommitteeState era
-> [(Voter, GovActionState era)]
-> Test (ConwayGovPredFailure era)
checkVotersAreValid EpochNo
currentEpoch CommitteeState era
committeeState [(Voter, GovActionState era)]
votes =
  forall era.
[(Voter, GovActionState era)]
-> (NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era)
-> (GovActionState era -> Voter -> Bool)
-> Test (ConwayGovPredFailure era)
checkDisallowedVotes [(Voter, GovActionState era)]
votes forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVoters forall a b. (a -> b) -> a -> b
$ \GovActionState era
gas ->
    \case
      CommitteeVoter {} -> forall era.
ConwayEraPParams era =>
EpochNo -> CommitteeState era -> GovAction era -> Bool
isCommitteeVotingAllowed EpochNo
currentEpoch CommitteeState era
committeeState (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
      DRepVoter {} -> forall era. ConwayEraPParams era => GovAction era -> Bool
isDRepVotingAllowed (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
      StakePoolVoter {} -> forall era. ConwayEraPParams era => GovAction era -> Bool
isStakePoolVotingAllowed (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)

checkBootstrapVotes ::
  forall era.
  EraPParams era =>
  PParams era ->
  [(Voter, GovActionState era)] ->
  Test (ConwayGovPredFailure era)
checkBootstrapVotes :: forall era.
EraPParams era =>
PParams era
-> [(Voter, GovActionState era)] -> Test (ConwayGovPredFailure era)
checkBootstrapVotes PParams era
pp [(Voter, GovActionState era)]
votes
  | 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 era.
[(Voter, GovActionState era)]
-> (NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era)
-> (GovActionState era -> Voter -> Bool)
-> Test (ConwayGovPredFailure era)
checkDisallowedVotes [(Voter, GovActionState era)]
votes forall era.
NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
DisallowedVotesDuringBootstrap forall a b. (a -> b) -> a -> b
$ \GovActionState era
gas ->
        \case
          DRepVoter {} | forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas forall a. Eq a => a -> a -> Bool
== forall era. GovAction era
InfoAction -> Bool
True
          DRepVoter {} -> Bool
False
          Voter
_ -> forall era. GovAction era -> Bool
isBootstrapAction forall a b. (a -> b) -> a -> b
$ forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

actionWellFormed ::
  ConwayEraPParams era => ProtVer -> GovAction era -> Test (ConwayGovPredFailure era)
actionWellFormed :: forall era.
ConwayEraPParams era =>
ProtVer -> GovAction era -> Test (ConwayGovPredFailure era)
actionWellFormed ProtVer
pv GovAction era
ga = forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless Bool
isWellFormed forall a b. (a -> b) -> a -> b
$ forall era. GovAction era -> ConwayGovPredFailure era
MalformedProposal GovAction era
ga
  where
    isWellFormed :: Bool
isWellFormed = case GovAction era
ga of
      ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
_ PParamsUpdate era
ppd StrictMaybe ScriptHash
_ -> forall era.
ConwayEraPParams era =>
ProtVer -> PParamsUpdate era -> Bool
ppuWellFormed ProtVer
pv PParamsUpdate era
ppd
      GovAction era
_ -> Bool
True

mkGovActionState ::
  GovActionId ->
  ProposalProcedure era ->
  -- | The number of epochs to expiry from protocol parameters
  EpochInterval ->
  -- | The current epoch
  EpochNo ->
  GovActionState era
mkGovActionState :: forall era.
GovActionId
-> ProposalProcedure era
-> EpochInterval
-> EpochNo
-> GovActionState era
mkGovActionState GovActionId
actionId ProposalProcedure era
proposal EpochInterval
expiryInterval EpochNo
curEpoch =
  GovActionState
    { gasId :: GovActionId
gasId = GovActionId
actionId
    , gasCommitteeVotes :: Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes = forall a. Monoid a => a
mempty
    , gasDRepVotes :: Map (Credential 'DRepRole) Vote
gasDRepVotes = forall a. Monoid a => a
mempty
    , gasStakePoolVotes :: Map (KeyHash 'StakePool) Vote
gasStakePoolVotes = forall a. Monoid a => a
mempty
    , gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure = ProposalProcedure era
proposal
    , gasProposedIn :: EpochNo
gasProposedIn = EpochNo
curEpoch
    , gasExpiresAfter :: EpochNo
gasExpiresAfter = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpoch EpochInterval
expiryInterval
    }

checkPolicy ::
  StrictMaybe ScriptHash ->
  StrictMaybe ScriptHash ->
  Test (ConwayGovPredFailure era)
checkPolicy :: forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> Test (ConwayGovPredFailure era)
checkPolicy StrictMaybe ScriptHash
expectedPolicyHash StrictMaybe ScriptHash
actualPolicyHash =
  forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (StrictMaybe ScriptHash
actualPolicyHash forall a. Eq a => a -> a -> Bool
== StrictMaybe ScriptHash
expectedPolicyHash) forall a b. (a -> b) -> a -> b
$
    forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> ConwayGovPredFailure era
InvalidPolicyHash StrictMaybe ScriptHash
actualPolicyHash StrictMaybe ScriptHash
expectedPolicyHash

checkBootstrapProposal ::
  EraPParams era =>
  PParams era ->
  ProposalProcedure era ->
  Test (ConwayGovPredFailure era)
checkBootstrapProposal :: forall era.
EraPParams era =>
PParams era
-> ProposalProcedure era -> Test (ConwayGovPredFailure era)
checkBootstrapProposal PParams era
pp proposal :: ProposalProcedure era
proposal@ProposalProcedure {GovAction era
pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
pProcGovAction :: GovAction era
pProcGovAction}
  | 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 e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (forall era. GovAction era -> Bool
isBootstrapAction GovAction era
pProcGovAction) forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

govTransition ::
  forall era.
  ( ConwayEraTxCert era
  , ConwayEraPParams era
  , STS (EraRule "GOV" era)
  , Event (EraRule "GOV" era) ~ ConwayGovEvent era
  , Signal (EraRule "GOV" era) ~ GovSignal era
  , PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era
  , BaseM (EraRule "GOV" era) ~ ShelleyBase
  , Environment (EraRule "GOV" era) ~ GovEnv era
  , State (EraRule "GOV" era) ~ Proposals era
  , InjectRuleFailure "GOV" ConwayGovPredFailure era
  ) =>
  TransitionRule (EraRule "GOV" era)
govTransition :: forall era.
(ConwayEraTxCert era, ConwayEraPParams era,
 STS (EraRule "GOV" era),
 Event (EraRule "GOV" era) ~ ConwayGovEvent era,
 Signal (EraRule "GOV" era) ~ GovSignal era,
 PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era,
 BaseM (EraRule "GOV" era) ~ ShelleyBase,
 Environment (EraRule "GOV" era) ~ GovEnv era,
 State (EraRule "GOV" era) ~ Proposals era,
 InjectRuleFailure "GOV" ConwayGovPredFailure era) =>
TransitionRule (EraRule "GOV" era)
govTransition = do
  TRC
    ( GovEnv TxId
txid EpochNo
currentEpoch PParams era
pp StrictMaybe ScriptHash
constitutionPolicy CertState {DState era
certDState :: forall era. CertState era -> DState era
certDState :: DState era
certDState, PState era
certPState :: forall era. CertState era -> PState era
certPState :: PState era
certPState, VState era
certVState :: forall era. CertState era -> VState era
certVState :: VState era
certVState}
      , State (EraRule "GOV" era)
st
      , GovSignal {VotingProcedures era
gsVotingProcedures :: VotingProcedures era
gsVotingProcedures :: forall era. GovSignal era -> VotingProcedures era
gsVotingProcedures, OSet (ProposalProcedure era)
gsProposalProcedures :: OSet (ProposalProcedure era)
gsProposalProcedures :: forall era. GovSignal era -> OSet (ProposalProcedure era)
gsProposalProcedures, StrictSeq (TxCert era)
gsCertificates :: StrictSeq (TxCert era)
gsCertificates :: forall era. GovSignal era -> StrictSeq (TxCert era)
gsCertificates}
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let prevGovActionIds :: GovRelation StrictMaybe era
prevGovActionIds = State (EraRule "GOV" era)
st forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
L.to forall era. GovRelation PRoot era -> GovRelation StrictMaybe era
toPrevGovActionIds
      committeeState :: CommitteeState era
committeeState = forall era. VState era -> CommitteeState era
vsCommitteeState VState era
certVState
      knownDReps :: Map (Credential 'DRepRole) DRepState
knownDReps = forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps VState era
certVState
      knownStakePools :: Map (KeyHash 'StakePool) PoolParams
knownStakePools = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
certPState
      knownCommitteeMembers :: Set (Credential 'HotCommitteeRole)
knownCommitteeMembers = forall era.
CommitteeState era -> Set (Credential 'HotCommitteeRole)
authorizedHotCommitteeCredentials CommitteeState era
committeeState

  Network
expectedNetworkId <- 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

  let processProposal :: Proposals era
-> (GovActionIx, ProposalProcedure era)
-> F (Clause (EraRule "GOV" era) 'Transition) (Proposals era)
processProposal Proposals era
ps (GovActionIx
idx, proposal :: ProposalProcedure era
proposal@ProposalProcedure {RewardAccount
Coin
Anchor
GovAction era
pProcAnchor :: forall era. ProposalProcedure era -> Anchor
pProcReturnAddr :: forall era. ProposalProcedure era -> RewardAccount
pProcDeposit :: forall era. ProposalProcedure era -> Coin
pProcAnchor :: Anchor
pProcGovAction :: GovAction era
pProcReturnAddr :: RewardAccount
pProcDeposit :: Coin
pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
..}) = do
        forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
PParams era
-> ProposalProcedure era -> Test (ConwayGovPredFailure era)
checkBootstrapProposal PParams era
pp ProposalProcedure era
proposal

        let newGaid :: GovActionId
newGaid = TxId -> GovActionIx -> GovActionId
GovActionId TxId
txid GovActionIx
idx

        -- In a HardFork, check that the ProtVer can follow
        let badHardFork :: Maybe (ConwayGovPredFailure era)
badHardFork = do
              (StrictMaybe (GovPurposeId 'HardForkPurpose era)
prevGaid, ProtVer
newProtVer, ProtVer
prevProtVer) <-
                forall era.
EraPParams era =>
GovAction era
-> PParams era
-> GovRelation StrictMaybe era
-> Proposals era
-> Maybe
     (StrictMaybe (GovPurposeId 'HardForkPurpose era), ProtVer, ProtVer)
preceedingHardFork @era GovAction era
pProcGovAction PParams era
pp GovRelation StrictMaybe era
prevGovActionIds State (EraRule "GOV" era)
st
              if ProtVer -> ProtVer -> Bool
pvCanFollow ProtVer
prevProtVer ProtVer
newProtVer
                then forall a. Maybe a
Nothing
                else
                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> Mismatch 'RelGT ProtVer -> ConwayGovPredFailure era
ProposalCantFollow @era StrictMaybe (GovPurposeId 'HardForkPurpose era)
prevGaid forall a b. (a -> b) -> a -> b
$
                      Mismatch
                        { mismatchSupplied :: ProtVer
mismatchSupplied = ProtVer
newProtVer
                        , mismatchExpected :: ProtVer
mismatchExpected = ProtVer
prevProtVer
                        }
        forall a sts (ctx :: RuleType).
Maybe a -> (a -> PredicateFailure sts) -> Rule sts ctx ()
failOnJust Maybe (ConwayGovPredFailure era)
badHardFork forall a. a -> a
id

        -- PParamsUpdate well-formedness check
        forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
ProtVer -> GovAction era -> Test (ConwayGovPredFailure era)
actionWellFormed (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL) GovAction era
pProcGovAction

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtVer -> Bool
HF.bootstrapPhase forall a b. (a -> b) -> a -> b
$ 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
$ do
          let refundAddress :: RewardAccount
refundAddress = ProposalProcedure era
proposal forall s a. s -> Getting a s a -> a
^. forall era. Lens' (ProposalProcedure era) RewardAccount
pProcReturnAddrL
              govAction :: GovAction era
govAction = ProposalProcedure era
proposal forall s a. s -> Getting a s a -> a
^. forall era. Lens' (ProposalProcedure era) (GovAction era)
pProcGovActionL
          Credential 'Staking -> UMap -> Bool
UMap.member' (RewardAccount -> Credential 'Staking
raCredential RewardAccount
refundAddress) (DState era
certDState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (DState era) UMap
dsUnifiedL)
            forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. RewardAccount -> ConwayGovPredFailure era
ProposalReturnAccountDoesNotExist RewardAccount
refundAddress
          case GovAction era
govAction of
            TreasuryWithdrawals Map RewardAccount Coin
withdrawals StrictMaybe ScriptHash
_ -> do
              let nonRegisteredAccounts :: Map RewardAccount Coin
nonRegisteredAccounts =
                    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Map RewardAccount Coin
withdrawals forall a b. (a -> b) -> a -> b
$ \RewardAccount
withdrawalAddress Coin
_ ->
                      Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Credential 'Staking -> UMap -> Bool
UMap.member' (RewardAccount -> Credential 'Staking
raCredential RewardAccount
withdrawalAddress) (DState era
certDState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (DState era) UMap
dsUnifiedL)
              forall (f :: * -> *) a sts (ctx :: RuleType).
Foldable f =>
f a -> (NonEmpty a -> PredicateFailure sts) -> Rule sts ctx ()
failOnNonEmpty (forall k a. Map k a -> [k]
Map.keys Map RewardAccount Coin
nonRegisteredAccounts) forall era. NonEmpty RewardAccount -> ConwayGovPredFailure era
TreasuryWithdrawalReturnAccountsDoNotExist
            GovAction era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Deposit check
        let expectedDep :: Coin
expectedDep = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
         in Coin
pProcDeposit
              forall a. Eq a => a -> a -> Bool
== Coin
expectedDep
                forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. Mismatch 'RelEQ Coin -> ConwayGovPredFailure era
ProposalDepositIncorrect
                  Mismatch
                    { mismatchSupplied :: Coin
mismatchSupplied = Coin
pProcDeposit
                    , mismatchExpected :: Coin
mismatchExpected = Coin
expectedDep
                    }

        -- Return address network id check
        RewardAccount -> Network
raNetwork RewardAccount
pProcReturnAddr
          forall a. Eq a => a -> a -> Bool
== Network
expectedNetworkId
            forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. RewardAccount -> Network -> ConwayGovPredFailure era
ProposalProcedureNetworkIdMismatch RewardAccount
pProcReturnAddr Network
expectedNetworkId

        -- Treasury withdrawal return address and committee well-formedness checks
        case GovAction era
pProcGovAction of
          TreasuryWithdrawals Map RewardAccount Coin
wdrls StrictMaybe ScriptHash
proposalPolicy ->
            let mismatchedAccounts :: Set RewardAccount
mismatchedAccounts =
                  forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((forall a. Eq a => a -> a -> Bool
/= Network
expectedNetworkId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RewardAccount -> Network
raNetwork) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map RewardAccount Coin
wdrls
             in do
                  forall a. Set a -> Bool
Set.null Set RewardAccount
mismatchedAccounts
                    forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Set RewardAccount -> Network -> ConwayGovPredFailure era
TreasuryWithdrawalsNetworkIdMismatch Set RewardAccount
mismatchedAccounts Network
expectedNetworkId

                  -- Policy check
                  forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> Test (ConwayGovPredFailure era)
checkPolicy @era StrictMaybe ScriptHash
constitutionPolicy StrictMaybe ScriptHash
proposalPolicy

                  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
$
                    -- The sum of all withdrawals must be positive
                    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold Map RewardAccount Coin
wdrls forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. GovAction era -> ConwayGovPredFailure era
ZeroTreasuryWithdrawals GovAction era
pProcGovAction
          UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
_mPrevGovActionId Set (Credential 'ColdCommitteeRole)
membersToRemove Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd UnitInterval
_qrm -> do
            Rule (EraRule "GOV" era) 'Transition ()
checkConflictingUpdate
            Rule (EraRule "GOV" era) 'Transition ()
checkExpirationEpoch
            where
              checkConflictingUpdate :: Rule (EraRule "GOV" era) 'Transition ()
checkConflictingUpdate =
                let conflicting :: Set (Credential 'ColdCommitteeRole)
conflicting =
                      forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                        (forall k a. Map k a -> Set k
Map.keysSet Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd)
                        Set (Credential 'ColdCommitteeRole)
membersToRemove
                 in forall a. Set a -> Bool
Set.null Set (Credential 'ColdCommitteeRole)
conflicting forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Set (Credential 'ColdCommitteeRole) -> ConwayGovPredFailure era
ConflictingCommitteeUpdate Set (Credential 'ColdCommitteeRole)
conflicting
              checkExpirationEpoch :: Rule (EraRule "GOV" era) 'Transition ()
checkExpirationEpoch =
                let invalidMembers :: Map (Credential 'ColdCommitteeRole) EpochNo
invalidMembers = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Ord a => a -> a -> Bool
<= EpochNo
currentEpoch) Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd
                 in forall k a. Map k a -> Bool
Map.null Map (Credential 'ColdCommitteeRole) EpochNo
invalidMembers forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> ConwayGovPredFailure era
ExpirationEpochTooSmall Map (Credential 'ColdCommitteeRole) EpochNo
invalidMembers
          ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
_ PParamsUpdate era
_ StrictMaybe ScriptHash
proposalPolicy ->
            forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe ScriptHash
-> StrictMaybe ScriptHash -> Test (ConwayGovPredFailure era)
checkPolicy @era StrictMaybe ScriptHash
constitutionPolicy StrictMaybe ScriptHash
proposalPolicy
          GovAction era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Ancestry checks and accept proposal
        let expiry :: EpochInterval
expiry = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL
            actionState :: GovActionState era
actionState =
              forall era.
GovActionId
-> ProposalProcedure era
-> EpochInterval
-> EpochNo
-> GovActionState era
mkGovActionState
                GovActionId
newGaid
                ProposalProcedure era
proposal
                EpochInterval
expiry
                EpochNo
currentEpoch
         in case forall era.
(EraPParams era, HasCallStack) =>
GovActionState era -> Proposals era -> Maybe (Proposals era)
proposalsAddAction GovActionState era
actionState Proposals era
ps of
              Just Proposals era
updatedPs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposals era
updatedPs
              Maybe (Proposals era)
Nothing -> Proposals era
ps forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (forall era. ProposalProcedure era -> ConwayGovPredFailure era
InvalidPrevGovActionId ProposalProcedure era
proposal)

  Proposals era
proposals <-
    forall (t :: * -> *) (m :: * -> *) ans k.
(Foldable t, Monad m) =>
(ans -> k -> m ans) -> ans -> t k -> m ans
foldlM' Proposals era
-> (GovActionIx, ProposalProcedure era)
-> F (Clause (EraRule "GOV" era) 'Transition) (Proposals era)
processProposal State (EraRule "GOV" era)
st forall a b. (a -> b) -> a -> b
$
      forall era.
Seq (ProposalProcedure era)
-> Seq (GovActionIx, ProposalProcedure era)
indexedGovProps (forall a. StrictSeq a -> Seq a
SSeq.fromStrict (forall a. OSet a -> StrictSeq a
OSet.toStrictSeq OSet (ProposalProcedure era)
gsProposalProcedures))

  -- Inversion of the keys in VotingProcedures, where we can find the voters for every
  -- govActionId
  let ([GovActionId]
unknownGovActionIds, [(Voter, GovActionState era)]
knownVotes, Set (Voter, GovActionId)
replacedVotes) =
        forall era c.
(Voter -> GovActionId -> VotingProcedure era -> c -> c)
-> c -> VotingProcedures era -> c
foldrVotingProcedures
          -- strictness is not needed for `unknown` or `replaced`
          ( \Voter
voter GovActionId
gaId VotingProcedure era
_ ([GovActionId]
unknown, ![(Voter, GovActionState era)]
known, Set (Voter, GovActionId)
replaced) ->
              case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GovActionId
gaId Map GovActionId (GovActionState era)
curGovActionIds of
                Just GovActionState era
gas ->
                  let isVoteReplaced :: Bool
isVoteReplaced =
                        case Voter
voter of
                          CommitteeVoter Credential 'HotCommitteeRole
hotCred -> Credential 'HotCommitteeRole
hotCred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era.
GovActionState era -> Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes GovActionState era
gas
                          DRepVoter Credential 'DRepRole
cred -> Credential 'DRepRole
cred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era. GovActionState era -> Map (Credential 'DRepRole) Vote
gasDRepVotes GovActionState era
gas
                          StakePoolVoter KeyHash 'StakePool
poolId -> KeyHash 'StakePool
poolId forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era. GovActionState era -> Map (KeyHash 'StakePool) Vote
gasStakePoolVotes GovActionState era
gas
                      replaced' :: Set (Voter, GovActionId)
replaced'
                        | Bool
isVoteReplaced = forall a. Ord a => a -> Set a -> Set a
Set.insert (Voter
voter, GovActionId
gaId) Set (Voter, GovActionId)
replaced
                        | Bool
otherwise = Set (Voter, GovActionId)
replaced
                   in ([GovActionId]
unknown, (Voter
voter, GovActionState era
gas) forall a. a -> [a] -> [a]
: [(Voter, GovActionState era)]
known, Set (Voter, GovActionId)
replaced')
                Maybe (GovActionState era)
Nothing -> (GovActionId
gaId forall a. a -> [a] -> [a]
: [GovActionId]
unknown, [(Voter, GovActionState era)]
known, Set (Voter, GovActionId)
replaced)
          )
          ([], [], forall a. Set a
Set.empty)
          VotingProcedures era
gsVotingProcedures
      curGovActionIds :: Map GovActionId (GovActionState era)
curGovActionIds = forall era. Proposals era -> Map GovActionId (GovActionState era)
proposalsActionsMap Proposals era
proposals
      isVoterKnown :: Voter -> Bool
isVoterKnown = \case
        CommitteeVoter Credential 'HotCommitteeRole
hotCred -> Credential 'HotCommitteeRole
hotCred forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Credential 'HotCommitteeRole)
knownCommitteeMembers
        DRepVoter Credential 'DRepRole
cred -> Credential 'DRepRole
cred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Credential 'DRepRole) DRepState
knownDReps
        StakePoolVoter KeyHash 'StakePool
poolId -> KeyHash 'StakePool
poolId forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'StakePool) PoolParams
knownStakePools
      unknownVoters :: [Voter]
unknownVoters =
        forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$
          forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Voter
voter Map GovActionId (VotingProcedure era)
_ -> Bool -> Bool
not (Voter -> Bool
isVoterKnown Voter
voter)) (forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures VotingProcedures era
gsVotingProcedures)

  forall (f :: * -> *) a sts (ctx :: RuleType).
Foldable f =>
f a -> (NonEmpty a -> PredicateFailure sts) -> Rule sts ctx ()
failOnNonEmpty [Voter]
unknownVoters forall era. NonEmpty Voter -> ConwayGovPredFailure era
VotersDoNotExist
  forall (f :: * -> *) a sts (ctx :: RuleType).
Foldable f =>
f a -> (NonEmpty a -> PredicateFailure sts) -> Rule sts ctx ()
failOnNonEmpty [GovActionId]
unknownGovActionIds forall era. NonEmpty GovActionId -> ConwayGovPredFailure era
GovActionsDoNotExist
  forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
PParams era
-> [(Voter, GovActionState era)] -> Test (ConwayGovPredFailure era)
checkBootstrapVotes PParams era
pp [(Voter, GovActionState era)]
knownVotes
  forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
EpochNo
-> [(Voter, GovActionState era)] -> Test (ConwayGovPredFailure era)
checkVotesAreNotForExpiredActions EpochNo
currentEpoch [(Voter, GovActionState era)]
knownVotes
  forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
EpochNo
-> CommitteeState era
-> [(Voter, GovActionState era)]
-> Test (ConwayGovPredFailure era)
checkVotersAreValid EpochNo
currentEpoch CommitteeState era
committeeState [(Voter, GovActionState era)]
knownVotes

  let
    addVoterVote :: Proposals era
-> Voter -> GovActionId -> VotingProcedure era -> Proposals era
addVoterVote Proposals era
ps Voter
voter GovActionId
govActionId VotingProcedure {Vote
vProcVote :: forall era. VotingProcedure era -> Vote
vProcVote :: Vote
vProcVote} =
      forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote Voter
voter Vote
vProcVote GovActionId
govActionId Proposals era
ps
    updatedProposalStates :: Proposals era
updatedProposalStates =
      Proposals era -> Proposals era
cleanupProposalVotes forall a b. (a -> b) -> a -> b
$
        forall c era.
(c -> Voter -> GovActionId -> VotingProcedure era -> c)
-> c -> VotingProcedures era -> c
foldlVotingProcedures forall {era} {era}.
Proposals era
-> Voter -> GovActionId -> VotingProcedure era -> Proposals era
addVoterVote Proposals era
proposals VotingProcedures era
gsVotingProcedures
    unregisteredDReps :: Set (Credential 'DRepRole)
unregisteredDReps =
      let collectRemovals :: Set (Credential 'DRepRole)
-> TxCert era -> Set (Credential 'DRepRole)
collectRemovals Set (Credential 'DRepRole)
drepCreds = \case
            UnRegDRepTxCert Credential 'DRepRole
drepCred Coin
_ -> forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'DRepRole
drepCred Set (Credential 'DRepRole)
drepCreds
            TxCert era
_ -> Set (Credential 'DRepRole)
drepCreds
       in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era}.
ConwayEraTxCert era =>
Set (Credential 'DRepRole)
-> TxCert era -> Set (Credential 'DRepRole)
collectRemovals forall a. Monoid a => a
mempty StrictSeq (TxCert era)
gsCertificates
    cleanupProposalVotes :: Proposals era -> Proposals era
cleanupProposalVotes =
      let cleanupVoters :: GovActionState era -> GovActionState era
cleanupVoters GovActionState era
gas =
            GovActionState era
gas forall a b. a -> (a -> b) -> b
& forall era.
Lens' (GovActionState era) (Map (Credential 'DRepRole) Vote)
gasDRepVotesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set (Credential 'DRepRole)
unregisteredDReps)
       in forall era.
(GovActionState era -> GovActionState era)
-> Proposals era -> Proposals era
mapProposals GovActionState era -> GovActionState era
cleanupVoters

  -- Report the event
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. TxId -> Proposals era -> ConwayGovEvent era
GovNewProposals TxId
txid Proposals era
updatedProposalStates
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era.
TxId
-> Set (Voter, GovActionId)
-> Set (Credential 'DRepRole)
-> ConwayGovEvent era
GovRemovedVotes TxId
txid Set (Voter, GovActionId)
replacedVotes Set (Credential 'DRepRole)
unregisteredDReps

  forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposals era
updatedProposalStates

isBootstrapAction :: GovAction era -> Bool
isBootstrapAction :: forall era. GovAction era -> Bool
isBootstrapAction =
  \case
    ParameterChange {} -> Bool
True
    HardForkInitiation {} -> Bool
True
    GovAction era
InfoAction -> Bool
True
    GovAction era
_ -> Bool
False

checkDisallowedVotes ::
  [(Voter, GovActionState era)] ->
  (NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era) ->
  (GovActionState era -> Voter -> Bool) ->
  Test (ConwayGovPredFailure era)
checkDisallowedVotes :: forall era.
[(Voter, GovActionState era)]
-> (NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era)
-> (GovActionState era -> Voter -> Bool)
-> Test (ConwayGovPredFailure era)
checkDisallowedVotes [(Voter, GovActionState era)]
votes NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
failure GovActionState era -> Voter -> Bool
canBeVotedOnBy =
  forall (f :: * -> *) a e.
Foldable f =>
f a -> (NonEmpty a -> e) -> Validation (NonEmpty e) ()
failureOnNonEmpty [(Voter, GovActionId)]
disallowedVotes NonEmpty (Voter, GovActionId) -> ConwayGovPredFailure era
failure
  where
    disallowedVotes :: [(Voter, GovActionId)]
disallowedVotes =
      [(Voter
voter, forall era. GovActionState era -> GovActionId
gasId GovActionState era
gas) | (Voter
voter, GovActionState era
gas) <- [(Voter, GovActionState era)]
votes, Bool -> Bool
not (GovActionState era
gas GovActionState era -> Voter -> Bool
`canBeVotedOnBy` Voter
voter)]

-- | If the GovAction is a HardFork, then return 3 things (if they exist)
-- 1) The (StrictMaybe GovPurposeId), pointed to by the HardFork proposal
-- 2) The proposed ProtVer
-- 3) The ProtVer of the preceeding HardFork
-- If it is not a HardFork, or the previous govActionId points to something other
-- than  HardFork, return Nothing. It will be verified with another predicate check.
preceedingHardFork ::
  EraPParams era =>
  GovAction era ->
  PParams era ->
  GovRelation StrictMaybe era ->
  Proposals era ->
  Maybe (StrictMaybe (GovPurposeId 'HardForkPurpose era), ProtVer, ProtVer)
preceedingHardFork :: forall era.
EraPParams era =>
GovAction era
-> PParams era
-> GovRelation StrictMaybe era
-> Proposals era
-> Maybe
     (StrictMaybe (GovPurposeId 'HardForkPurpose era), ProtVer, ProtVer)
preceedingHardFork (HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose era)
mPrev ProtVer
newProtVer) PParams era
pp GovRelation StrictMaybe era
pgaids Proposals era
ps
  | StrictMaybe (GovPurposeId 'HardForkPurpose era)
mPrev forall a. Eq a => a -> a -> Bool
== GovRelation StrictMaybe era
pgaids forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL = forall a. a -> Maybe a
Just (StrictMaybe (GovPurposeId 'HardForkPurpose era)
mPrev, ProtVer
newProtVer, PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
  | Bool
otherwise = do
      SJust (GovPurposeId GovActionId
prevGovActionId) <- forall a. a -> Maybe a
Just StrictMaybe (GovPurposeId 'HardForkPurpose era)
mPrev
      HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose era)
_ ProtVer
prevProtVer <- forall era. GovActionState era -> GovAction era
gasAction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
GovActionId -> Proposals era -> Maybe (GovActionState era)
proposalsLookupId GovActionId
prevGovActionId Proposals era
ps
      forall a. a -> Maybe a
Just (StrictMaybe (GovPurposeId 'HardForkPurpose era)
mPrev, ProtVer
newProtVer, ProtVer
prevProtVer)
preceedingHardFork GovAction era
_ PParams era
_ GovRelation StrictMaybe era
_ Proposals era
_ = forall a. Maybe a
Nothing