{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Conway.ImpTest (
  module Test.Cardano.Ledger.Babbage.ImpTest,
  ConwayEraImp,
  enactConstitution,
  enactTreasuryWithdrawals,
  submitGovAction,
  submitGovAction_,
  submitGovActions,
  submitProposal,
  submitAndExpireProposalToMakeReward,
  submitProposal_,
  submitProposals,
  submitFailingProposal,
  trySubmitGovAction,
  trySubmitGovActions,
  trySubmitProposal,
  trySubmitProposals,
  submitTreasuryWithdrawals,
  submitVote,
  submitVote_,
  submitYesVote_,
  submitFailingVote,
  trySubmitVote,
  registerDRep,
  unRegisterDRep,
  updateDRep,
  delegateToDRep,
  setupSingleDRep,
  setupDRepWithoutStake,
  setupPoolWithStake,
  setupPoolWithoutStake,
  conwayModifyPParams,
  getProposals,
  getEnactState,
  getGovActionState,
  lookupGovActionState,
  expectPresentGovActionId,
  expectMissingGovActionId,
  getRatifyEnv,
  calculateDRepAcceptedRatio,
  calculatePoolAcceptedRatio,
  calculateCommitteeAcceptedRatio,
  logAcceptedRatio,
  isDRepAccepted,
  isSpoAccepted,
  isCommitteeAccepted,
  getCommitteeMembers,
  getConstitution,
  registerInitialCommittee,
  logRatificationChecks,
  resignCommitteeColdKey,
  registerCommitteeHotKey,
  registerCommitteeHotKeys,
  logCurPParams,
  electCommittee,
  electBasicCommittee,
  proposalsShowDebug,
  getGovPolicy,
  submitFailingGovAction,
  submitConstitutionGovAction,
  submitGovActionForest,
  submitGovActionTree,
  getProposalsForest,
  logProposalsForest,
  logProposalsForestDiff,
  constitutionShouldBe,
  getCCExpiry,
  ccShouldBeExpired,
  ccShouldNotBeExpired,
  ccShouldBeResigned,
  ccShouldNotBeResigned,
  getLastEnactedCommittee,
  getLastEnactedConstitution,
  submitParameterChange,
  submitUpdateCommittee,
  expectCommitteeMemberPresence,
  expectCommitteeMemberAbsence,
  getLastEnactedParameterChange,
  getLastEnactedHardForkInitiation,
  getConstitutionProposals,
  getParameterChangeProposals,
  expectNumDormantEpochs,
  submitConstitution,
  isDRepExpired,
  expectDRepExpiry,
  expectActualDRepExpiry,
  expectDRepNotRegistered,
  expectCurrentProposals,
  expectNoCurrentProposals,
  expectPulserProposals,
  expectNoPulserProposals,
  minorFollow,
  majorFollow,
  cantFollow,
  getsPParams,
  currentProposalsShouldContain,
  withImpStateWithProtVer,
  ifBootstrap,
  whenPostBootstrap,
  submitYesVoteCCs_,
  donateToTreasury,
  expectMembers,
  showConwayTxBalance,
  logConwayTxBalance,
) where

import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN, Signable)
import Cardano.Crypto.Hash.Blake2b (Blake2b_224)
import Cardano.Crypto.Hash.Class (Hash)
import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
import Cardano.Ledger.Allegra.Scripts (Timelock)
import Cardano.Ledger.Alonzo.Scripts (AlonzoScript)
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  Network (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  Version,
  addEpochInterval,
  binOpEpochNo,
  hashAnchorData,
  inject,
  succVersion,
  textToUrl,
 )
import Cardano.Ledger.CertState (
  CertState,
  CommitteeAuthorization (..),
  certPStateL,
  csCommitteeCredsL,
  psStakePoolParamsL,
  vsActualDRepExpiry,
  vsNumDormantEpochsL,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core hiding (proposals)
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..))
import Cardano.Ledger.Conway.Rules (
  ConwayGovEvent,
  EnactSignal,
  committeeAccepted,
  committeeAcceptedRatio,
  dRepAccepted,
  dRepAcceptedRatio,
  prevActionAsExpected,
  spoAccepted,
  spoAcceptedRatio,
  validCommitteeTerm,
  withdrawalCanWithdraw,
 )
import Cardano.Ledger.Conway.Tx (AlonzoTx)
import Cardano.Ledger.Conway.TxCert (Delegatee (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import qualified Cardano.Ledger.Shelley.HardForks as HardForks (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState (
  IncrementalStake (..),
  asTreasuryL,
  certVStateL,
  consumed,
  curPParamsEpochStateL,
  epochStateGovStateL,
  epochStatePoolParamsL,
  esAccountStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEpochStateL,
  nesEsL,
  nesPdL,
  newEpochStateGovStateL,
  produced,
  unifiedL,
  utxosGovStateL,
  utxosStakeDistrL,
  utxosUtxoL,
  vsCommitteeStateL,
  vsDRepsL,
 )
import Cardano.Ledger.TxIn (TxId (..))
import Cardano.Ledger.UMap (dRepMap)
import Cardano.Ledger.UTxO (EraUTxO, UTxO, balance, sumAllValue, txInsFilter)
import Cardano.Ledger.Val (Val (..), (<->))
import Control.Monad (forM)
import Control.Monad.Trans.Fail.String (errorFail)
import Control.State.Transition.Extended (STS (..))
import Data.Bifunctor (bimap)
import Data.Default.Class (Default (..))
import Data.Foldable (Foldable (..))
import Data.Functor.Identity
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Tree
import qualified GHC.Exts as GHC (fromList)
import Lens.Micro
import Prettyprinter (align, hsep, viaShow, vsep)
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.TreeDiff (tableDoc)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkCred)
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (testingCostModel)

-- | Modify the PParams in the current state with the given function
conwayModifyPParams ::
  ConwayEraGov era =>
  (PParams era -> PParams era) ->
  ImpTestM era ()
conwayModifyPParams :: forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES forall a b. (a -> b) -> a -> b
$ \NewEpochState era
nes ->
  NewEpochState era
nes
    forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f
    forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser
  where
    modifyDRepPulser :: DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser DRepPulsingState era
pulser =
      case forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
pulser of
        (PulsingSnapshot era
snapshot, RatifyState era
ratifyState) ->
          forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snapshot (RatifyState era
ratifyState forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EnactState era) (PParams era)
ensCurPParamsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f)

withImpStateWithProtVer ::
  forall era.
  ConwayEraImp era =>
  Version ->
  SpecWith (ImpTestState era) ->
  Spec
withImpStateWithProtVer :: forall era.
ConwayEraImp era =>
Version -> SpecWith (ImpTestState era) -> Spec
withImpStateWithProtVer Version
ver = do
  forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era)
-> SpecWith (ImpTestState era) -> Spec
withImpStateModified forall a b. (a -> b) -> a -> b
$
    forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (ConwayGovState era) (PParams era)
cgsCurPParamsL
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer Version
ver Natural
0

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  , Eq (ConwayGovEvent (ConwayEra c))
  ) =>
  ShelleyEraImp (ConwayEra c)
  where
  initGenesis :: forall s (m :: * -> *).
(HasKeyPairs s (EraCrypto (ConwayEra c)), MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Genesis (ConwayEra c))
initGenesis = do
    KeyHash 'ColdCommitteeRole c
kh1 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
    KeyHash 'ColdCommitteeRole c
kh2 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
    let
      ccExpiryEpochNo :: EpochNo
ccExpiryEpochNo = EpochNo -> EpochInterval -> EpochNo
addEpochInterval (forall era. Era era => EpochNo
impEraStartEpochNo @(ConwayEra c)) (Word32 -> EpochInterval
EpochInterval Word32
15)
      committee :: Committee (ConwayEra c)
committee = forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval -> Committee era
Committee [(forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'ColdCommitteeRole c
kh1, EpochNo
ccExpiryEpochNo), (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'ColdCommitteeRole c
kh2, EpochNo
ccExpiryEpochNo)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
      constitutionAnchor :: Anchor c
constitutionAnchor =
        Anchor
          { anchorUrl :: Url
anchorUrl = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
128 Text
"https://cardano-constitution.crypto"
          , anchorDataHash :: SafeHash c AnchorData
anchorDataHash = forall c. Crypto c => AnchorData -> SafeHash c AnchorData
hashAnchorData (ByteString -> AnchorData
AnchorData ByteString
"Cardano Constitution Content")
          }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ConwayGenesis
        { cgUpgradePParams :: UpgradeConwayPParams Identity
cgUpgradePParams =
            UpgradeConwayPParams
              { ucppPoolVotingThresholds :: HKD Identity PoolVotingThresholds
ucppPoolVotingThresholds =
                  PoolVotingThresholds
                    { pvtMotionNoConfidence :: UnitInterval
pvtMotionNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtCommitteeNormal :: UnitInterval
pvtCommitteeNormal = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtCommitteeNoConfidence :: UnitInterval
pvtCommitteeNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtHardForkInitiation :: UnitInterval
pvtHardForkInitiation = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtPPSecurityGroup :: UnitInterval
pvtPPSecurityGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    }
              , ucppDRepVotingThresholds :: HKD Identity DRepVotingThresholds
ucppDRepVotingThresholds =
                  DRepVotingThresholds
                    { dvtMotionNoConfidence :: UnitInterval
dvtMotionNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtCommitteeNormal :: UnitInterval
dvtCommitteeNormal = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtCommitteeNoConfidence :: UnitInterval
dvtCommitteeNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtUpdateToConstitution :: UnitInterval
dvtUpdateToConstitution = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtHardForkInitiation :: UnitInterval
dvtHardForkInitiation = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPNetworkGroup :: UnitInterval
dvtPPNetworkGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPEconomicGroup :: UnitInterval
dvtPPEconomicGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPTechnicalGroup :: UnitInterval
dvtPPTechnicalGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPGovGroup :: UnitInterval
dvtPPGovGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtTreasuryWithdrawal :: UnitInterval
dvtTreasuryWithdrawal = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    }
              , ucppCommitteeMinSize :: HKD Identity Word16
ucppCommitteeMinSize = Word16
1
              , ucppCommitteeMaxTermLength :: HKD Identity EpochInterval
ucppCommitteeMaxTermLength = Word32 -> EpochInterval
EpochInterval Word32
20
              , ucppGovActionLifetime :: HKD Identity EpochInterval
ucppGovActionLifetime = Word32 -> EpochInterval
EpochInterval Word32
30
              , ucppGovActionDeposit :: HKD Identity Coin
ucppGovActionDeposit = Integer -> Coin
Coin Integer
123
              , ucppDRepDeposit :: HKD Identity Coin
ucppDRepDeposit = Integer -> Coin
Coin Integer
70_000_000
              , ucppDRepActivity :: HKD Identity EpochInterval
ucppDRepActivity = Word32 -> EpochInterval
EpochInterval Word32
100
              , ucppMinFeeRefScriptCostPerByte :: HKD Identity NonNegativeInterval
ucppMinFeeRefScriptCostPerByte = Integer
15 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
              , -- TODO: Replace with correct cost model.
                ucppPlutusV3CostModel :: HKD Identity CostModel
ucppPlutusV3CostModel = HasCallStack => Language -> CostModel
testingCostModel Language
PlutusV3
              }
        , cgConstitution :: Constitution (ConwayEra c)
cgConstitution = forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor c
constitutionAnchor forall a. StrictMaybe a
SNothing
        , cgCommittee :: Committee (ConwayEra c)
cgCommittee = Committee (ConwayEra c)
committee
        , cgDelegs :: ListMap (Credential 'Staking c) (Delegatee c)
cgDelegs = forall a. Monoid a => a
mempty
        , cgInitialDReps :: ListMap (Credential 'DRepRole c) (DRepState c)
cgInitialDReps = forall a. Monoid a => a
mempty
        }

  impSatisfyNativeScript :: Set (KeyHash 'Witness (EraCrypto (ConwayEra c)))
-> NativeScript (ConwayEra c)
-> ImpTestM
     (ConwayEra c)
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto (ConwayEra c)))
           (KeyPair 'Witness (EraCrypto (ConwayEra c)))))
impSatisfyNativeScript = forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness (EraCrypto era))
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impAllegraSatisfyNativeScript

  modifyPParams :: (PParams (ConwayEra c) -> PParams (ConwayEra c))
-> ImpTestM (ConwayEra c) ()
modifyPParams = forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams

  fixupTx :: HasCallStack =>
Tx (ConwayEra c) -> ImpTestM (ConwayEra c) (Tx (ConwayEra c))
fixupTx = forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  ) =>
  MaryEraImp (ConwayEra c)

instance ShelleyEraImp (ConwayEra c) => AlonzoEraImp (ConwayEra c) where
  scriptTestContexts :: Map (ScriptHash (EraCrypto (ConwayEra c))) ScriptTestContext
scriptTestContexts =
    forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
SLanguage l -> Map (ScriptHash c) ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1
      forall a. Semigroup a => a -> a -> a
<> forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
SLanguage l -> Map (ScriptHash c) ScriptTestContext
plutusTestScripts SLanguage 'PlutusV2
SPlutusV2
      forall a. Semigroup a => a -> a -> a
<> forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
SLanguage l -> Map (ScriptHash c) ScriptTestContext
plutusTestScripts SLanguage 'PlutusV3
SPlutusV3

class
  ( AlonzoEraImp era
  , ConwayEraGov era
  , ConwayEraTxBody era
  , ConwayEraTxCert era
  , ConwayEraPParams era
  , STS (EraRule "ENACT" era)
  , BaseM (EraRule "ENACT" era) ~ ShelleyBase
  , State (EraRule "ENACT" era) ~ EnactState era
  , Signal (EraRule "ENACT" era) ~ EnactSignal era
  , Environment (EraRule "ENACT" era) ~ ()
  , NativeScript era ~ Timelock era
  , Script era ~ AlonzoScript era
  , GovState era ~ ConwayGovState era
  ) =>
  ConwayEraImp era

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  ) =>
  ConwayEraImp (ConwayEra c)

registerInitialCommittee ::
  (HasCallStack, ConwayEraImp era) =>
  ImpTestM era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee = do
  [Credential 'ColdCommitteeRole (EraCrypto era)]
committeeMembers <- forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
  case [Credential 'ColdCommitteeRole (EraCrypto era)]
committeeMembers of
    Credential 'ColdCommitteeRole (EraCrypto era)
x : [Credential 'ColdCommitteeRole (EraCrypto era)]
xs -> forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
-> NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era))
-> ImpTestM
     era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerCommitteeHotKeys (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash) forall a b. (a -> b) -> a -> b
$ Credential 'ColdCommitteeRole (EraCrypto era)
x forall a. a -> [a] -> NonEmpty a
NE.:| [Credential 'ColdCommitteeRole (EraCrypto era)]
xs
    [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"Expected an initial committee"

-- | Submit a transaction that registers a new DRep and return the keyhash
-- belonging to that DRep
registerDRep :: ConwayEraImp era => ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep = do
  -- Register a DRep
  KeyHash 'DRepRole (EraCrypto era)
khDRep <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Register DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton
          ( forall era.
ConwayEraTxCert era =>
Credential 'DRepRole (EraCrypto era)
-> Coin -> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
RegDRepTxCert
              (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
khDRep)
              (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL)
              forall a. StrictMaybe a
SNothing
          )
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall k a. Ord k => k -> Map k a -> Bool
Map.member (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
khDRep)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash 'DRepRole (EraCrypto era)
khDRep

-- | Submit a transaction that unregisters a given DRep
unRegisterDRep ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential 'DRepRole (EraCrypto era) ->
  ImpTestM era ()
unRegisterDRep :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era ()
unRegisterDRep Credential 'DRepRole (EraCrypto era)
drep = do
  DRepState (EraCrypto era)
drepState <- forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era)
-> ImpTestM era (DRepState (EraCrypto era))
lookupDRepState Credential 'DRepRole (EraCrypto era)
drep
  let refund :: Coin
refund = forall c. DRepState c -> Coin
drepDeposit DRepState (EraCrypto era)
drepState
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"UnRegister DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ConwayEraTxCert era =>
Credential 'DRepRole (EraCrypto era) -> Coin -> TxCert era
UnRegDRepTxCert Credential 'DRepRole (EraCrypto era)
drep Coin
refund)

-- | Submit a transaction that updates a given DRep
updateDRep ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential 'DRepRole (EraCrypto era) ->
  ImpTestM era ()
updateDRep :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era ()
updateDRep Credential 'DRepRole (EraCrypto era)
drep = do
  StrictMaybe (Anchor (EraCrypto era))
mAnchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Update DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ConwayEraTxCert era =>
Credential 'DRepRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
UpdateDRepTxCert Credential 'DRepRole (EraCrypto era)
drep StrictMaybe (Anchor (EraCrypto era))
mAnchor)

-- | In contrast to `setupSingleDRep`, this function does not make a UTxO entry
-- that could count as delegated stake to the DRep
setupDRepWithoutStake ::
  ConwayEraImp era =>
  ImpTestM
    era
    ( KeyHash 'DRepRole (EraCrypto era)
    , KeyHash 'Staking (EraCrypto era)
    )
setupDRepWithoutStake :: forall era.
ConwayEraImp era =>
ImpTestM
  era
  (KeyHash 'DRepRole (EraCrypto era),
   KeyHash 'Staking (EraCrypto era))
setupDRepWithoutStake = do
  KeyHash 'DRepRole (EraCrypto era)
drepKH <- forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep
  KeyHash 'Staking (EraCrypto era)
delegatorKH <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
              (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
delegatorKH)
              (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
drepKH))
              Coin
deposit
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'DRepRole (EraCrypto era)
drepKH, KeyHash 'Staking (EraCrypto era)
delegatorKH)

-- | Registers a new DRep, registers its stake credentials and delegates the specified amount of ADA to it.
setupSingleDRep ::
  ConwayEraImp era =>
  Integer ->
  ImpTestM
    era
    ( Credential 'DRepRole (EraCrypto era)
    , Credential 'Staking (EraCrypto era)
    , KeyPair 'Payment (EraCrypto era)
    )
setupSingleDRep :: forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
stake = do
  KeyHash 'DRepRole (EraCrypto era)
drepKH <- forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep
  KeyHash 'Staking (EraCrypto era)
delegatorKH <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
  let tx :: Tx era
tx =
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
              [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert
                  (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
delegatorKH)
                  Coin
deposit
              ]
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
  KeyPair 'Payment (EraCrypto era)
spendingKP <-
    forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era)
-> Coin
-> DRep (EraCrypto era)
-> ImpTestM era (KeyPair 'Payment (EraCrypto era))
delegateToDRep (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
delegatorKH) (Integer -> Coin
Coin Integer
stake) (forall c. Credential 'DRepRole c -> DRep c
DRepCredential (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
drepKH))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
drepKH, forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
delegatorKH, KeyPair 'Payment (EraCrypto era)
spendingKP)

delegateToDRep ::
  ConwayEraImp era =>
  Credential 'Staking (EraCrypto era) ->
  Coin ->
  DRep (EraCrypto era) ->
  ImpTestM
    era
    (KeyPair 'Payment (EraCrypto era))
delegateToDRep :: forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era)
-> Coin
-> DRep (EraCrypto era)
-> ImpTestM era (KeyPair 'Payment (EraCrypto era))
delegateToDRep Credential 'Staking (EraCrypto era)
cred Coin
stake DRep (EraCrypto era)
dRep = do
  (KeyHash 'Payment (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
spendingKP) <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
  let addr :: Addr (EraCrypto era)
addr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall c (kr :: KeyRole).
Crypto c =>
KeyPair kr c -> Credential kr c
mkCred KeyPair 'Payment (EraCrypto era)
spendingKP) (forall c. StakeCredential c -> StakeReference c
StakeRefBase Credential 'Staking (EraCrypto era)
cred)
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton
          ( forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut
              Addr (EraCrypto era)
addr
              (forall t s. Inject t s => t -> s
inject Coin
stake)
          )
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert
              Credential 'Staking (EraCrypto era)
cred
              (forall c. DRep c -> Delegatee c
DelegVote DRep (EraCrypto era)
dRep)
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyPair 'Payment (EraCrypto era)
spendingKP

lookupDRepState ::
  HasCallStack =>
  Credential 'DRepRole (EraCrypto era) ->
  ImpTestM era (DRepState (EraCrypto era))
lookupDRepState :: forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era)
-> ImpTestM era (DRepState (EraCrypto era))
lookupDRepState Credential 'DRepRole (EraCrypto era)
dRepCred = do
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
drepsState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
dRepCred Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
drepsState of
    Maybe (DRepState (EraCrypto era))
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Expected for DRep " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'DRepRole (EraCrypto era)
dRepCred forall a. [a] -> [a] -> [a]
++ [Char]
" to be present in the CertState"
    Just DRepState (EraCrypto era)
state -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DRepState (EraCrypto era)
state

getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams :: forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams Lens' (PParams era) a
f = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' (PParams era) a
f

-- | Sets up a stake pool with coin delegated to it.
--
-- NOTE: This uses the `RegDepositDelegTxCert` for delegating, so it has to be
-- in Conway. The Shelley version of this function would have to separately
-- register the staking credential and then delegate it.
setupPoolWithStake ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Coin ->
  ImpTestM
    era
    ( KeyHash 'StakePool (EraCrypto era)
    , Credential 'Payment (EraCrypto era)
    , Credential 'Staking (EraCrypto era)
    )
setupPoolWithStake :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake Coin
delegCoin = do
  KeyHash 'StakePool (EraCrypto era)
khPool <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
khPool
  Credential 'Payment (EraCrypto era)
credDelegatorPayment <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  Credential 'Staking (EraCrypto era)
credDelegatorStaking <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo
      (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet Credential 'Payment (EraCrypto era)
credDelegatorPayment (forall c. StakeCredential c -> StakeReference c
StakeRefBase Credential 'Staking (EraCrypto era)
credDelegatorStaking))
      Coin
delegCoin
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to stake pool" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
              Credential 'Staking (EraCrypto era)
credDelegatorStaking
              (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
khPool)
              (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool (EraCrypto era)
khPool, Credential 'Payment (EraCrypto era)
credDelegatorPayment, Credential 'Staking (EraCrypto era)
credDelegatorStaking)

setupPoolWithoutStake ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  ImpTestM
    era
    ( KeyHash 'StakePool (EraCrypto era)
    , Credential 'Staking (EraCrypto era)
    )
setupPoolWithoutStake :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM
  era
  (KeyHash 'StakePool (EraCrypto era),
   Credential 'Staking (EraCrypto era))
setupPoolWithoutStake = do
  KeyHash 'StakePool (EraCrypto era)
khPool <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
khPool
  Credential 'Staking (EraCrypto era)
credDelegatorStaking <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to stake pool" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
              Credential 'Staking (EraCrypto era)
credDelegatorStaking
              (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
khPool)
              Coin
deposit
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool (EraCrypto era)
khPool, Credential 'Staking (EraCrypto era)
credDelegatorStaking)

-- | Submits a transaction with a Vote for the given governance action as
-- some voter
submitVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Vote ->
  Voter (EraCrypto era) ->
  GovActionId (EraCrypto era) ->
  ImpTestM era (TxId (EraCrypto era))
submitVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM era (TxId (EraCrypto era))
submitVote Vote
vote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (TxId (EraCrypto era)))
trySubmitVote Vote
vote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeep

-- | Submits a transaction that votes "Yes" for the given governance action as
-- some voter
submitYesVote_ ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Voter (EraCrypto era) ->
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
submitYesVote_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM era (TxId (EraCrypto era))
submitVote Vote
VoteYes Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId

submitVote_ ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Vote ->
  Voter (EraCrypto era) ->
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
submitVote_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM era ()
submitVote_ Vote
vote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM era (TxId (EraCrypto era))
submitVote Vote
vote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId

submitFailingVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Voter (EraCrypto era) ->
  GovActionId (EraCrypto era) ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingVote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure =
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (TxId (EraCrypto era)))
trySubmitVote Vote
VoteYes Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

-- | Submits a transaction that votes "Yes" for the given governance action as
-- some voter, and expects an `Either` result.
trySubmitVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  Vote ->
  Voter (EraCrypto era) ->
  GovActionId (EraCrypto era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (TxId (EraCrypto era))
    )
trySubmitVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter (EraCrypto era)
-> GovActionId (EraCrypto era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (TxId (EraCrypto era)))
trySubmitVote Vote
vote Voter (EraCrypto era)
voter GovActionId (EraCrypto era)
gaId =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> a
fst forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx) forall a b. (a -> b) -> a -> b
$
    forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
        forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
          forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
Map
  (Voter (EraCrypto era))
  (Map (GovActionId (EraCrypto era)) (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
            ( forall k a. k -> a -> Map k a
Map.singleton
                Voter (EraCrypto era)
voter
                ( forall k a. k -> a -> Map k a
Map.singleton
                    GovActionId (EraCrypto era)
gaId
                    ( VotingProcedure
                        { vProcVote :: Vote
vProcVote = Vote
vote
                        , vProcAnchor :: StrictMaybe (Anchor (EraCrypto era))
vProcAnchor = forall a. StrictMaybe a
SNothing
                        }
                    )
                )
            )

submitProposal_ ::
  (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
  ProposalProcedure era ->
  ImpTestM era ()
submitProposal_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era))
submitProposal

submitProposal ::
  (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
  ProposalProcedure era ->
  ImpTestM era (GovActionId (EraCrypto era))
submitProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era))
submitProposal ProposalProcedure era
proposal = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era)))
trySubmitProposal ProposalProcedure era
proposal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr

submitProposals ::
  (ShelleyEraImp era, ConwayEraGov era, ConwayEraTxBody era, HasCallStack) =>
  NE.NonEmpty (ProposalProcedure era) ->
  ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era)))
submitProposals :: forall era.
(ShelleyEraImp era, ConwayEraGov era, ConwayEraTxBody era,
 HasCallStack) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM era (NonEmpty (GovActionId (EraCrypto era)))
submitProposals NonEmpty (ProposalProcedure era)
proposals = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  Tx era
tx <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr
  let txId :: TxId (EraCrypto era)
txId = forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx Tx era
tx
      proposalsWithGovActionId :: NonEmpty (GovActionId (EraCrypto era), ProposalProcedure era)
proposalsWithGovActionId =
        forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Word16
idx ProposalProcedure era
p -> (forall c. TxId c -> GovActionIx -> GovActionId c
GovActionId TxId (EraCrypto era)
txId (Word16 -> GovActionIx
GovActionIx Word16
idx), ProposalProcedure era
p)) (Word16
0 forall a. a -> [a] -> NonEmpty a
NE.:| [Word16
1 ..]) NonEmpty (ProposalProcedure era)
proposals
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (GovActionId (EraCrypto era), ProposalProcedure era)
proposalsWithGovActionId forall a b. (a -> b) -> a -> b
$ \(GovActionId (EraCrypto era)
govActionId, ProposalProcedure era
proposal) -> do
    GovActionState era
govActionState <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
govActionId
    GovActionState era
govActionState
      forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` GovActionState
        { gasId :: GovActionId (EraCrypto era)
gasId = GovActionId (EraCrypto era)
govActionId
        , gasCommitteeVotes :: Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes = forall a. Monoid a => a
mempty
        , gasDRepVotes :: Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes = forall a. Monoid a => a
mempty
        , gasStakePoolVotes :: Map (KeyHash 'StakePool (EraCrypto era)) Vote
gasStakePoolVotes = forall a. Monoid a => a
mempty
        , gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure = ProposalProcedure era
proposal
        , gasProposedIn :: EpochNo
gasProposedIn = EpochNo
curEpochNo
        , gasExpiresAfter :: EpochNo
gasExpiresAfter = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL)
        }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId (EraCrypto era)
govActionId

-- | Submits a transaction that proposes the given proposal
trySubmitProposal ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  ProposalProcedure era ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era))
    )
trySubmitProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era)))
trySubmitProposal ProposalProcedure era
proposal = do
  Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals (forall (f :: * -> *) a. Applicative f => a -> f a
pure ProposalProcedure era
proposal)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res of
    Right Tx era
tx ->
      forall a b. b -> Either a b
Right
        GovActionId
          { gaidTxId :: TxId (EraCrypto era)
gaidTxId = forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx Tx era
tx
          , gaidGovActionIx :: GovActionIx
gaidGovActionIx = Word16 -> GovActionIx
GovActionIx Word16
0
          }
    Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
err, Tx era
_) -> forall a b. a -> Either a b
Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
err

trySubmitProposals ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  NE.NonEmpty (ProposalProcedure era) ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitProposals :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals = do
  forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall l. IsList l => [Item l] -> l
GHC.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ProposalProcedure era)
proposals)

submitFailingProposal ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  ProposalProcedure era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingProposal ProposalProcedure era
proposal NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure =
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era)))
trySubmitProposal ProposalProcedure era
proposal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

-- | Submits a transaction that proposes the given governance action. For proposing
-- multiple actions in the same transaciton use `trySubmitGovActions` instead.
trySubmitGovAction ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  GovAction era ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era))
    )
trySubmitGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era)))
trySubmitGovAction GovAction era
ga = do
  let mkGovActionId :: Tx era -> GovActionId (EraCrypto era)
mkGovActionId Tx era
tx = forall c. TxId c -> GovActionIx -> GovActionId c
GovActionId (forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx Tx era
tx) (Word16 -> GovActionIx
GovActionIx Word16
0)
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> a
fst forall {era}. EraTx era => Tx era -> GovActionId (EraCrypto era)
mkGovActionId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions (forall (f :: * -> *) a. Applicative f => a -> f a
pure GovAction era
ga)

submitAndExpireProposalToMakeReward ::
  ConwayEraImp era =>
  Credential 'Staking (EraCrypto era) ->
  ImpTestM era ()
submitAndExpireProposalToMakeReward :: forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking (EraCrypto era)
stakingC = do
  RewardAccount (EraCrypto era)
rewardAccount <- forall era.
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
getRewardAccountFor Credential 'Staking (EraCrypto era)
stakingC
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let
    EpochInterval Word32
lifetime = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL
    deposit :: Coin
deposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
  GovActionId (EraCrypto era)
gai <-
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era))
submitProposal forall a b. (a -> b) -> a -> b
$
      ProposalProcedure
        { pProcDeposit :: Coin
pProcDeposit = Coin
deposit
        , pProcReturnAddr :: RewardAccount (EraCrypto era)
pProcReturnAddr = RewardAccount (EraCrypto era)
rewardAccount
        , pProcGovAction :: GovAction era
pProcGovAction = forall era. GovAction era
InfoAction
        , pProcAnchor :: Anchor (EraCrypto era)
pProcAnchor = forall a. Default a => a
def
        }
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ Natural
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
lifetime
  forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
expectMissingGovActionId GovActionId (EraCrypto era)
gai

-- | Submits a transaction that proposes the given governance action
trySubmitGovActions ::
  (ShelleyEraImp era, ConwayEraTxBody era) =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitGovActions :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions NonEmpty (GovAction era)
gas = do
  Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
  RewardAccount (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
  Anchor (EraCrypto era)
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  NonEmpty (ProposalProcedure era)
proposals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (GovAction era)
gas forall a b. (a -> b) -> a -> b
$ \GovAction era
ga -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ProposalProcedure
        { pProcDeposit :: Coin
pProcDeposit = Coin
deposit
        , pProcReturnAddr :: RewardAccount (EraCrypto era)
pProcReturnAddr = RewardAccount (EraCrypto era)
rewardAccount
        , pProcGovAction :: GovAction era
pProcGovAction = GovAction era
ga
        , pProcAnchor :: Anchor (EraCrypto era)
pProcAnchor = Anchor (EraCrypto era)
anchor
        }
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals

submitGovAction ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  ImpTestM era (GovActionId (EraCrypto era))
submitGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
ga = do
  GovActionId (EraCrypto era)
gaId NE.:| [GovActionId (EraCrypto era)]
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era)
-> ImpTestM era (NonEmpty (GovActionId (EraCrypto era)))
submitGovActions (forall (f :: * -> *) a. Applicative f => a -> f a
pure GovAction era
ga)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId (EraCrypto era)
gaId

submitGovAction_ ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  ImpTestM era ()
submitGovAction_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction

submitGovActions ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era)))
submitGovActions :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era)
-> ImpTestM era (NonEmpty (GovActionId (EraCrypto era)))
submitGovActions NonEmpty (GovAction era)
gas = do
  Tx era
tx <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions NonEmpty (GovAction era)
gas forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr
  let txId :: TxId (EraCrypto era)
txId = forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx Tx era
tx
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Word16
idx GovAction era
_ -> forall c. TxId c -> GovActionIx -> GovActionId c
GovActionId TxId (EraCrypto era)
txId (Word16 -> GovActionIx
GovActionIx Word16
idx)) (Word16
0 forall a. a -> [a] -> NonEmpty a
NE.:| [Word16
1 ..]) NonEmpty (GovAction era)
gas

submitTreasuryWithdrawals ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , ConwayEraGov era
  ) =>
  [(RewardAccount (EraCrypto era), Coin)] ->
  ImpTestM era (GovActionId (EraCrypto era))
submitTreasuryWithdrawals :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount (EraCrypto era), Coin)]
-> ImpTestM era (GovActionId (EraCrypto era))
submitTreasuryWithdrawals [(RewardAccount (EraCrypto era), Coin)]
wdrls = do
  StrictMaybe (ScriptHash (EraCrypto era))
policy <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era)))
getGovPolicy
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> StrictMaybe (ScriptHash (EraCrypto era)) -> GovAction era
TreasuryWithdrawals (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount (EraCrypto era), Coin)]
wdrls) StrictMaybe (ScriptHash (EraCrypto era))
policy

enactTreasuryWithdrawals ::
  ConwayEraImp era =>
  [(RewardAccount (EraCrypto era), Coin)] ->
  Credential 'DRepRole (EraCrypto era) ->
  NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)) ->
  ImpTestM era (GovActionId (EraCrypto era))
enactTreasuryWithdrawals :: forall era.
ConwayEraImp era =>
[(RewardAccount (EraCrypto era), Coin)]
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactTreasuryWithdrawals [(RewardAccount (EraCrypto era), Coin)]
withdrawals Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
cms = do
  GovActionId (EraCrypto era)
gaId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount (EraCrypto era), Coin)]
-> ImpTestM era (GovActionId (EraCrypto era))
submitTreasuryWithdrawals [(RewardAccount (EraCrypto era), Coin)]
withdrawals
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep) GovActionId (EraCrypto era)
gaId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
cms GovActionId (EraCrypto era)
gaId
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId (EraCrypto era)
gaId

submitParameterChange ::
  ConwayEraImp era =>
  StrictMaybe (GovActionId (EraCrypto era)) ->
  PParamsUpdate era ->
  ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange :: forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange StrictMaybe (GovActionId (EraCrypto era))
parent PParamsUpdate era
ppu = do
  StrictMaybe (ScriptHash (EraCrypto era))
policy <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era)))
getGovPolicy
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era
-> StrictMaybe (ScriptHash (EraCrypto era))
-> GovAction era
ParameterChange (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (GovActionId (EraCrypto era))
parent) PParamsUpdate era
ppu StrictMaybe (ScriptHash (EraCrypto era))
policy

getGovPolicy :: ConwayEraGov era => ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era)))
getGovPolicy :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era)))
getGovPolicy =
  forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$
    forall era. Lens' (NewEpochState era) (EpochState era)
nesEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (Constitution era) (StrictMaybe (ScriptHash (EraCrypto era)))
constitutionScriptL

submitFailingGovAction ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingGovAction GovAction era
ga NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (GovActionId (EraCrypto era)))
trySubmitGovAction GovAction era
ga forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

getEnactState :: ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState :: forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState = forall era. ConwayEraGov era => GovState era -> EnactState era
mkEnactState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL)

getProposals :: ConwayEraGov era => ImpTestM era (Proposals era)
getProposals :: forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL

logProposalsForest :: (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest :: forall era. (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest = do
  Proposals era
proposals <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug Proposals era
proposals Bool
True

getCommitteeMembers ::
  ConwayEraImp era =>
  ImpTestM era (Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers :: forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers = do
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers StrictMaybe (Committee era)
committee

getLastEnactedCommittee ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getConstitution ::
  ConwayEraImp era =>
  ImpTestM era (Constitution era)
getConstitution :: forall era. ConwayEraImp era => ImpTestM era (Constitution era)
getConstitution = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL

getLastEnactedConstitution ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose era))
getLastEnactedConstitution :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose era))
getLastEnactedConstitution = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getLastEnactedParameterChange ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getLastEnactedHardForkInitiation ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getConstitutionProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'ConstitutionPurpose era)
        (PEdges (GovPurposeId 'ConstitutionPurpose era))
    )
getConstitutionProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'ConstitutionPurpose era)
     (PEdges (GovPurposeId 'ConstitutionPurpose era)))
getConstitutionProposals = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL

getParameterChangeProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'PParamUpdatePurpose era)
        (PEdges (GovPurposeId 'PParamUpdatePurpose era))
    )
getParameterChangeProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'PParamUpdatePurpose era)
     (PEdges (GovPurposeId 'PParamUpdatePurpose era)))
getParameterChangeProposals = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL

logProposalsForestDiff ::
  ( Era era
  , ToExpr (PParamsHKD StrictMaybe era)
  , HasCallStack
  ) =>
  Proposals era ->
  Proposals era ->
  ImpTestM era ()
logProposalsForestDiff :: forall era.
(Era era, ToExpr (PParamsHKD StrictMaybe era), HasCallStack) =>
Proposals era -> Proposals era -> ImpTestM era ()
logProposalsForestDiff Proposals era
pf1 Proposals era
pf2 = forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep [Doc AnsiStyle
"Proposals Forest Diff:", forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Proposals era
pf1 Proposals era
pf2]

-- | Looks up the governance action state corresponding to the governance action id
lookupGovActionState ::
  ConwayEraGov era =>
  GovActionId (EraCrypto era) ->
  ImpTestM era (Maybe (GovActionState era))
lookupGovActionState :: forall era.
ConwayEraGov era =>
GovActionId (EraCrypto era)
-> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId (EraCrypto era)
aId = forall era.
GovActionId (EraCrypto era)
-> Proposals era -> Maybe (GovActionState era)
proposalsLookupId GovActionId (EraCrypto era)
aId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals

-- | Looks up the governance action state corresponding to the governance action id
getGovActionState ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era (GovActionState era)
getGovActionState :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
govActionId =
  forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"Expecting an action state" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ConwayEraGov era =>
GovActionId (EraCrypto era)
-> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId (EraCrypto era)
govActionId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (GovActionState era)
Nothing ->
        forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find action state for govActionId: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show GovActionId (EraCrypto era)
govActionId
      Just GovActionState era
govActionState -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionState era
govActionState

expectPresentGovActionId ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
expectPresentGovActionId :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
expectPresentGovActionId GovActionId (EraCrypto era)
govActionId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
govActionId

expectMissingGovActionId ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
expectMissingGovActionId :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
expectMissingGovActionId GovActionId (EraCrypto era)
govActionId =
  forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"Expecting for gov action state to be missing" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ConwayEraGov era =>
GovActionId (EraCrypto era)
-> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId (EraCrypto era)
govActionId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just GovActionState era
_ ->
        forall (m :: * -> *). (HasCallStack, MonadIO m) => [Char] -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Found gov action state for govActionId: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> [Char]
ansiExprString GovActionId (EraCrypto era)
govActionId
      Maybe (GovActionState era)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Builds a RatifyEnv from the current state
getRatifyEnv :: ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv :: forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv = do
  EpochNo
eNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  IncrementalStake (EraCrypto era)
stakeDistr <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (UTxOState era) (IncrementalStake (EraCrypto era))
utxosStakeDistrL
  PoolDistr (EraCrypto era)
poolDistr <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) (PoolDistr (EraCrypto era))
nesPdL
  Map (DRep (EraCrypto era)) (CompactForm Coin)
drepDistr <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SimpleGetter
  (DRepPulsingState era)
  (Map (DRep (EraCrypto era)) (CompactForm Coin))
psDRepDistrG
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
drepState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL
  CommitteeState era
committeeState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall 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
  UMap (EraCrypto era)
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (UMap (EraCrypto era))
unifiedL
  Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolPs <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (EpochState era)
  (Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
epochStatePoolParamsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    RatifyEnv
      { reStakePoolDistr :: PoolDistr (EraCrypto era)
reStakePoolDistr = PoolDistr (EraCrypto era)
poolDistr
      , reStakeDistr :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
reStakeDistr = forall c.
IncrementalStake c
-> Map (Credential 'Staking c) (CompactForm Coin)
credMap IncrementalStake (EraCrypto era)
stakeDistr
      , reDRepState :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
reDRepState = Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
drepState
      , reDRepDistr :: Map (DRep (EraCrypto era)) (CompactForm Coin)
reDRepDistr = Map (DRep (EraCrypto era)) (CompactForm Coin)
drepDistr
      , reCurrentEpoch :: EpochNo
reCurrentEpoch = EpochNo
eNo forall a. Num a => a -> a -> a
- EpochNo
1
      , reCommitteeState :: CommitteeState era
reCommitteeState = CommitteeState era
committeeState
      , reDelegatees :: Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
reDelegatees = forall c. UMap c -> Map (Credential 'Staking c) (DRep c)
dRepMap UMap (EraCrypto era)
umap
      , rePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
rePoolParams = Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolPs
      }

ccShouldNotBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole (EraCrypto era) ->
  ImpTestM era ()
ccShouldNotBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldNotBeExpired Credential 'ColdCommitteeRole (EraCrypto era)
coldC = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  EpochNo
ccExpiryEpochNo <- forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole (EraCrypto era)
coldC
  EpochNo
curEpochNo forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` (forall a. Ord a => a -> a -> Bool
<= EpochNo
ccExpiryEpochNo)

ccShouldBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole (EraCrypto era) ->
  ImpTestM era ()
ccShouldBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldBeExpired Credential 'ColdCommitteeRole (EraCrypto era)
coldC = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  EpochNo
ccExpiryEpochNo <- forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole (EraCrypto era)
coldC
  EpochNo
curEpochNo forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` (forall a. Ord a => a -> a -> Bool
> EpochNo
ccExpiryEpochNo)

getCCExpiry ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole (EraCrypto era) ->
  ImpTestM era EpochNo
getCCExpiry :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole (EraCrypto era)
coldC = do
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  case StrictMaybe (Committee era)
committee of
    StrictMaybe (Committee era)
SNothing -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure [Char]
"There is no committee"
    SJust Committee {Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers :: forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers} ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole (EraCrypto era)
coldC Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers of
        Maybe EpochNo
Nothing -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Committee not found for cold credential: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole (EraCrypto era)
coldC
        Just EpochNo
epochNo -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochNo
epochNo

-- | Test the resignation status for a CC cold key to be resigned
ccShouldBeResigned ::
  HasCallStack => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldBeResigned :: forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
coldK = do
  Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeeCreds <-
    forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall 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 (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era)))
csCommitteeCredsL
  forall c.
CommitteeAuthorization c -> Maybe (Credential 'HotCommitteeRole c)
authHk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole (EraCrypto era)
coldK Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeeCreds forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just forall a. Maybe a
Nothing

-- | Test the resignation status for a CC cold key to not be resigned
ccShouldNotBeResigned ::
  HasCallStack => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldNotBeResigned :: forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
coldK = do
  Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeeCreds <-
    forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall 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 (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era)))
csCommitteeCredsL
  (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole (EraCrypto era)
coldK Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeeCreds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c.
CommitteeAuthorization c -> Maybe (Credential 'HotCommitteeRole c)
authHk) forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall a. Maybe a -> Bool
isJust

authHk :: CommitteeAuthorization c -> Maybe (Credential 'HotCommitteeRole c)
authHk :: forall c.
CommitteeAuthorization c -> Maybe (Credential 'HotCommitteeRole c)
authHk (CommitteeHotCredential Credential 'HotCommitteeRole c
hk) = forall a. a -> Maybe a
Just Credential 'HotCommitteeRole c
hk
authHk CommitteeAuthorization c
_ = forall a. Maybe a
Nothing

-- | Calculates the ratio of DReps that have voted for the governance action
calculateDRepAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era Rational
calculateDRepAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculateDRepAcceptedRatio GovActionId (EraCrypto era)
gaId = do
  RatifyEnv era
ratEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState era
gas <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
RatifyEnv era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
-> GovAction era
-> Rational
dRepAcceptedRatio @era
      RatifyEnv era
ratEnv
      (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (GovActionState era)
  (Map (Credential 'DRepRole (EraCrypto era)) Vote)
gasDRepVotesL)
      (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)

-- | Calculates the ratio of Committee members that have voted for the governance
-- action
calculateCommitteeAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era Rational
calculateCommitteeAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculateCommitteeAcceptedRatio GovActionId (EraCrypto era)
gaId = do
  EpochNo
eNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  RatifyEnv {CommitteeState era
reCommitteeState :: CommitteeState era
reCommitteeState :: forall era. RatifyEnv era -> CommitteeState era
reCommitteeState} <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState {Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes :: Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes :: forall era.
GovActionState era
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes} <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  let
    members :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers @era) StrictMaybe (Committee era)
committee
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio
      Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members
      Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes
      CommitteeState era
reCommitteeState
      EpochNo
eNo

calculatePoolAcceptedRatio ::
  ConwayEraGov era => GovActionId (EraCrypto era) -> ImpTestM era Rational
calculatePoolAcceptedRatio :: forall era.
ConwayEraGov era =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculatePoolAcceptedRatio GovActionId (EraCrypto era)
gaId = do
  RatifyEnv era
ratEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState era
gas <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
ratEnv GovActionState era
gas ProtVer
pv

-- | Logs the ratios of accepted votes per category
logAcceptedRatio ::
  (HasCallStack, ConwayEraGov era) => GovActionId (EraCrypto era) -> ImpTestM era ()
logAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
logAcceptedRatio GovActionId (EraCrypto era)
aId = do
  Rational
dRepRatio <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculateDRepAcceptedRatio GovActionId (EraCrypto era)
aId
  Rational
committeeRatio <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculateCommitteeAcceptedRatio GovActionId (EraCrypto era)
aId
  Rational
spoRatio <- forall era.
ConwayEraGov era =>
GovActionId (EraCrypto era) -> ImpTestM era Rational
calculatePoolAcceptedRatio GovActionId (EraCrypto era)
aId
  forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc forall a b. (a -> b) -> a -> b
$
    Maybe (Doc AnsiStyle) -> [([Char], Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc
      (forall a. a -> Maybe a
Just Doc AnsiStyle
"ACCEPTED RATIOS")
      [ ([Char]
"DRep accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
dRepRatio)
      , ([Char]
"Committee accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
committeeRatio)
      , ([Char]
"SPO accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
spoRatio)
      ]

getRatifyEnvAndState :: ConwayEraGov era => ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState :: forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState = do
  RatifyEnv era
ratifyEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  EnactState era
enactState <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
  let ratifyState :: RatifyState era
ratifyState =
        RatifyState
          { rsEnactState :: EnactState era
rsEnactState = EnactState era
enactState
          , rsEnacted :: Seq (GovActionState era)
rsEnacted = forall a. Monoid a => a
mempty
          , rsExpired :: Set (GovActionId (EraCrypto era))
rsExpired = forall a. Monoid a => a
mempty
          , rsDelayed :: Bool
rsDelayed = Bool
False
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState)

-- | Checks whether the governance action has enough DRep votes to be accepted in the next
-- epoch. (Note that no other checks except DRep votes are used)
isDRepAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era Bool
isDRepAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId (EraCrypto era) -> ImpTestM era Bool
isDRepAccepted GovActionId (EraCrypto era)
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

isSpoAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era Bool
isSpoAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId (EraCrypto era) -> ImpTestM era Bool
isSpoAccepted GovActionId (EraCrypto era)
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

isCommitteeAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era Bool
isCommitteeAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId (EraCrypto era) -> ImpTestM era Bool
isCommitteeAccepted GovActionId (EraCrypto era)
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

-- | Logs the results of each check required to make the governance action pass
logRatificationChecks ::
  (ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
logRatificationChecks :: forall era.
(ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
logRatificationChecks GovActionId (EraCrypto era)
gaId = do
  gas :: GovActionState era
gas@GovActionState {Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes :: Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes :: forall era.
GovActionState era
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes, Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes :: Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes :: forall era.
GovActionState era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes} <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
gaId
  let govAction :: GovAction era
govAction = forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
  ens :: EnactState era
ens@EnactState {Map (Credential 'Staking (EraCrypto era)) Coin
PParams era
StrictMaybe (Committee era)
Coin
GovRelation StrictMaybe era
Constitution era
ensCommittee :: forall era. EnactState era -> StrictMaybe (Committee era)
ensConstitution :: forall era. EnactState era -> Constitution era
ensCurPParams :: forall era. EnactState era -> PParams era
ensPrevPParams :: forall era. EnactState era -> PParams era
ensTreasury :: forall era. EnactState era -> Coin
ensWithdrawals :: forall era.
EnactState era -> Map (Credential 'Staking (EraCrypto era)) Coin
ensPrevGovActionIds :: forall era. EnactState era -> GovRelation StrictMaybe era
ensPrevGovActionIds :: GovRelation StrictMaybe era
ensWithdrawals :: Map (Credential 'Staking (EraCrypto era)) Coin
ensTreasury :: Coin
ensPrevPParams :: PParams era
ensCurPParams :: PParams era
ensConstitution :: Constitution era
ensCommittee :: StrictMaybe (Committee era)
..} <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  ratEnv :: RatifyEnv era
ratEnv@RatifyEnv {EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch} <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  let ratSt :: RatifyState era
ratSt = forall era.
EnactState era
-> Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Bool
-> RatifyState era
RatifyState EnactState era
ens forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Bool
False
  Coin
curTreasury <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' AccountState Coin
asTreasuryL
  EpochNo
currentEpoch <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  let
    members :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
    committeeState :: CommitteeState era
committeeState = forall era. RatifyEnv era -> CommitteeState era
reCommitteeState RatifyEnv era
ratEnv
  PParams era
curPParams <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL
  forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc forall a b. (a -> b) -> a -> b
$
    Maybe (Doc AnsiStyle) -> [([Char], Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc
      (forall a. a -> Maybe a
Just Doc AnsiStyle
"RATIFICATION CHECKS")
      [ ([Char]
"prevActionAsExpected:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
GovActionState era -> GovRelation StrictMaybe era -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe era
ensPrevGovActionIds)
      , ([Char]
"validCommitteeTerm:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
GovAction era -> PParams era -> EpochNo -> Bool
validCommitteeTerm GovAction era
govAction PParams era
curPParams EpochNo
currentEpoch)
      , ([Char]
"notDelayed:", Doc AnsiStyle
"??")
      , ([Char]
"withdrawalCanWithdraw:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era. GovAction era -> Coin -> Bool
withdrawalCanWithdraw GovAction era
govAction Coin
curTreasury)
      ,
        ( [Char]
"committeeAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes CommitteeState era
committeeState EpochNo
currentEpoch
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
EpochNo
-> RatifyState era
-> CommitteeState era
-> GovAction era
-> StrictMaybe UnitInterval
votingCommitteeThreshold EpochNo
reCurrentEpoch RatifyState era
ratSt CommitteeState era
committeeState (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ,
        ( [Char]
"spoAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
ratEnv GovActionState era
gas ProtVer
pv
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingStakePoolThreshold RatifyState era
ratSt (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ,
        ( [Char]
"dRepAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
-> GovAction era
-> Rational
dRepAcceptedRatio RatifyEnv era
ratEnv Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingDRepThreshold RatifyState era
ratSt (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ]

-- | Submits a transaction that registers a hot key for the given cold key.
-- Returns the hot key hash.
registerCommitteeHotKey ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Credential 'ColdCommitteeRole (EraCrypto era) ->
  ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
registerCommitteeHotKey :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
registerCommitteeHotKey Credential 'ColdCommitteeRole (EraCrypto era)
coldKey = do
  Credential 'HotCommitteeRole (EraCrypto era)
hotKey NE.:| [] <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
-> NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era))
-> ImpTestM
     era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerCommitteeHotKeys (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'ColdCommitteeRole (EraCrypto era)
coldKey
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'HotCommitteeRole (EraCrypto era)
hotKey

registerCommitteeHotKeys ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  -- | Hot Credential generator
  ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) ->
  NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era)) ->
  ImpTestM era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerCommitteeHotKeys :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
-> NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era))
-> ImpTestM
     era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerCommitteeHotKeys ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
genHotCred NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era))
coldKeys = do
  NonEmpty
  (Credential 'ColdCommitteeRole (EraCrypto era),
   Credential 'HotCommitteeRole (EraCrypto era))
keys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era))
coldKeys (\Credential 'ColdCommitteeRole (EraCrypto era)
coldKey -> (,) Credential 'ColdCommitteeRole (EraCrypto era)
coldKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
genHotCred)
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Registering Committee Hot keys" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> Credential 'HotCommitteeRole (EraCrypto era) -> TxCert era
AuthCommitteeHotKeyTxCert) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty
  (Credential 'ColdCommitteeRole (EraCrypto era),
   Credential 'HotCommitteeRole (EraCrypto era))
keys))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd NonEmpty
  (Credential 'ColdCommitteeRole (EraCrypto era),
   Credential 'HotCommitteeRole (EraCrypto era))
keys

-- | Submits a transaction that resigns the cold key. Prior to resignation if there was
-- hot credential authorization for this committee member it will be returned.
resignCommitteeColdKey ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Credential 'ColdCommitteeRole (EraCrypto era) ->
  StrictMaybe (Anchor (EraCrypto era)) ->
  ImpTestM era (Maybe (Credential 'HotCommitteeRole (EraCrypto era)))
resignCommitteeColdKey :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era))
-> ImpTestM
     era (Maybe (Credential 'HotCommitteeRole (EraCrypto era)))
resignCommitteeColdKey Credential 'ColdCommitteeRole (EraCrypto era)
coldKey StrictMaybe (Anchor (EraCrypto era))
anchor = do
  Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeAuthorizations <-
    forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$
      forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall 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 (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era)))
csCommitteeCredsL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Resigning Committee Cold key" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
ResignCommitteeColdTxCert Credential 'ColdCommitteeRole (EraCrypto era)
coldKey StrictMaybe (Anchor (EraCrypto era))
anchor)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    CommitteeHotCredential Credential 'HotCommitteeRole (EraCrypto era)
hotCred <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole (EraCrypto era)
coldKey Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
committeAuthorizations
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'HotCommitteeRole (EraCrypto era)
hotCred

electCommittee ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  StrictMaybe (GovPurposeId 'CommitteePurpose era) ->
  Credential 'DRepRole (EraCrypto era) ->
  Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) ->
  Map.Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo ->
  ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Credential 'DRepRole (EraCrypto era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
prevGovId Credential 'DRepRole (EraCrypto era)
drep Set (Credential 'ColdCommitteeRole (EraCrypto era))
toRemove Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
toAdd = forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"Electing committee" forall a b. (a -> b) -> a -> b
$ do
  let
    committeeAction :: GovAction era
committeeAction =
      forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
        StrictMaybe (GovPurposeId 'CommitteePurpose era)
prevGovId
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
toRemove
        Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
toAdd
        (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
  GovActionId (EraCrypto era)
gaidCommitteeProp <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
committeeAction
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drep) GovActionId (EraCrypto era)
gaidCommitteeProp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
gaidCommitteeProp)

electBasicCommittee ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  ImpTestM
    era
    ( Credential 'DRepRole (EraCrypto era)
    , Credential 'HotCommitteeRole (EraCrypto era)
    , GovPurposeId 'CommitteePurpose era
    )
electBasicCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential 'DRepRole (EraCrypto era),
   Credential 'HotCommitteeRole (EraCrypto era),
   GovPurposeId 'CommitteePurpose era)
electBasicCommittee = do
  forall era. HasCallStack => [Char] -> ImpTestM era ()
logString [Char]
"Setting up a DRep"
  (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
  (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000

  forall era. HasCallStack => [Char] -> ImpTestM era ()
logString [Char]
"Registering committee member"
  Credential 'ColdCommitteeRole (EraCrypto era)
coldCommitteeC <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  EpochNo
startEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  let
    committeeAction :: GovAction era
committeeAction =
      forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
        forall a. StrictMaybe a
SNothing
        forall a. Monoid a => a
mempty
        (forall k a. k -> a -> Map k a
Map.singleton Credential 'ColdCommitteeRole (EraCrypto era)
coldCommitteeC (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)))
        (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
  (GovActionId (EraCrypto era)
gaidCommitteeProp NE.:| [GovActionId (EraCrypto era)]
_) <-
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era)
-> ImpTestM era (NonEmpty (GovActionId (EraCrypto era)))
submitGovActions
      [ GovAction era
committeeAction
      , forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee forall a. StrictMaybe a
SNothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
      ]
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drep) GovActionId (EraCrypto era)
gaidCommitteeProp
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
gaidCommitteeProp
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  Set (Credential 'ColdCommitteeRole (EraCrypto era))
committeeMembers <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
  forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"The committee should be enacted" forall a b. (a -> b) -> a -> b
$
    Set (Credential 'ColdCommitteeRole (EraCrypto era))
committeeMembers forall a (m :: * -> *).
(HasCallStack, Show a, MonadIO m) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall a. Ord a => a -> Set a -> Bool
Set.member Credential 'ColdCommitteeRole (EraCrypto era)
coldCommitteeC
  Credential 'HotCommitteeRole (EraCrypto era)
hotCommitteeC <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
registerCommitteeHotKey Credential 'ColdCommitteeRole (EraCrypto era)
coldCommitteeC
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential 'DRepRole (EraCrypto era)
drep, Credential 'HotCommitteeRole (EraCrypto era)
hotCommitteeC, forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
gaidCommitteeProp)

logCurPParams ::
  ( EraGov era
  , ToExpr (PParamsHKD Identity era)
  , HasCallStack
  ) =>
  ImpTestM era ()
logCurPParams :: forall era.
(EraGov era, ToExpr (PParamsHKD Identity era), HasCallStack) =>
ImpTestM era ()
logCurPParams = do
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc forall a b. (a -> b) -> a -> b
$
    forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc AnsiStyle
""
      , Doc AnsiStyle
"----- Current PParams -----"
      , forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr PParams era
pp
      , Doc AnsiStyle
"---------------------------"
      , Doc AnsiStyle
""
      ]

proposalsShowDebug :: Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug :: forall era. Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug Proposals era
ps Bool
showRoots =
  forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
    [ Doc AnsiStyle
""
    , Doc AnsiStyle
"----- Proposals -----"
    , Doc AnsiStyle
"Size"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era. Proposals era -> Int
proposalsSize Proposals era
ps
    , Doc AnsiStyle
"OMap"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds Proposals era
ps
    , Doc AnsiStyle
""
    , Doc AnsiStyle
"Roots"
    , Doc AnsiStyle
"> PParamUpdate"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL
    , Doc AnsiStyle
"> HardFork"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL
    , Doc AnsiStyle
"> Committee"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL
    , Doc AnsiStyle
"> Constitution"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL
    ]
      forall a. Semigroup a => a -> a -> a
<> ( if Bool
showRoots
            then
              [ Doc AnsiStyle
"Hierarchy"
              , Doc AnsiStyle
">> PParamUpdate"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> HardFork"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> Committee"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> Constitution"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              ]
            else forall a. Monoid a => a
mempty
         )
      forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle
"----- Proposals End -----"]

submitConstitutionGovAction ::
  (ShelleyEraImp era, ConwayEraTxBody era) =>
  StrictMaybe (GovActionId (EraCrypto era)) ->
  ImpTestM era (GovActionId (EraCrypto era))
submitConstitutionGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
submitConstitutionGovAction StrictMaybe (GovActionId (EraCrypto era))
gid = do
  SafeHash (EraCrypto era) AnchorData
constitutionHash <- forall era a. Era era => ImpTestM era (SafeHash (EraCrypto era) a)
freshSafeHash
  let constitutionAction :: GovAction era
constitutionAction =
        forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era -> GovAction era
NewConstitution
          (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (GovActionId (EraCrypto era))
gid)
          ( forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution
              ( forall c. Url -> SafeHash c AnchorData -> Anchor c
Anchor
                  (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
64 Text
"constitution.dummy.0")
                  SafeHash (EraCrypto era) AnchorData
constitutionHash
              )
              forall a. StrictMaybe a
SNothing
          )
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
constitutionAction

getProposalsForest ::
  ConwayEraGov era =>
  ImpTestM era (Forest (StrictMaybe (GovActionId (EraCrypto era))))
getProposalsForest :: forall era.
ConwayEraGov era =>
ImpTestM era (Forest (StrictMaybe (GovActionId (EraCrypto era))))
getProposalsForest = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe (GovActionId (EraCrypto era))
mkRoot forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era
-> Forest (StrictMaybe (GovActionId (EraCrypto era)))
mkForest forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe (GovActionId (EraCrypto era))
mkRoot forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era
-> Forest (StrictMaybe (GovActionId (EraCrypto era)))
mkForest forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe (GovActionId (EraCrypto era))
mkRoot forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era
-> Forest (StrictMaybe (GovActionId (EraCrypto era)))
mkForest forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe (GovActionId (EraCrypto era))
mkRoot forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era
-> Forest (StrictMaybe (GovActionId (EraCrypto era)))
mkForest forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL Proposals era
ps
    ]
  where
    mkRoot ::
      Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era)) ->
      Proposals era ->
      StrictMaybe (GovActionId (EraCrypto era))
    mkRoot :: forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe (GovActionId (EraCrypto era))
mkRoot Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
rootL Proposals era
ps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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
. Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
rootL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL
    mkForest ::
      (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
      Proposals era ->
      Forest (StrictMaybe (GovActionId (EraCrypto era)))
    mkForest :: forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era
-> Forest (StrictMaybe (GovActionId (EraCrypto era)))
mkForest forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL Proposals era
ps =
      let h :: Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
h = Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
          s :: [GovActionId (EraCrypto era)]
s = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds Proposals era
ps
          getOrderedChildren :: Set (GovPurposeId p era) -> [GovActionId (EraCrypto era)]
getOrderedChildren Set (GovPurposeId p era)
cs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.member` forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId p era)
cs) [GovActionId (EraCrypto era)]
s
          go :: GovActionId (EraCrypto era)
-> (StrictMaybe (GovActionId (EraCrypto era)),
    [GovActionId (EraCrypto era)])
go GovActionId (EraCrypto era)
c = (forall a. a -> StrictMaybe a
SJust GovActionId (EraCrypto era)
c, Set (GovPurposeId p era) -> [GovActionId (EraCrypto era)]
getOrderedChildren forall a b. (a -> b) -> a -> b
$ Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
h forall k a. Ord k => Map k a -> k -> a
Map.! forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
c forall s a. s -> Getting a s a -> a
^. forall a. Lens' (PEdges a) (Set a)
peChildrenL)
       in forall b a. (b -> (a, [b])) -> [b] -> [Tree a]
unfoldForest GovActionId (EraCrypto era)
-> (StrictMaybe (GovActionId (EraCrypto era)),
    [GovActionId (EraCrypto era)])
go (Set (GovPurposeId p era) -> [GovActionId (EraCrypto era)]
getOrderedChildren forall a b. (a -> b) -> a -> b
$ Proposals era
ps 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 (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL)

submitGovActionTree ::
  (StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era))) ->
  StrictMaybe (GovActionId (EraCrypto era)) ->
  Tree () ->
  ImpTestM era (Tree (GovActionId (EraCrypto era)))
submitGovActionTree :: forall era.
(StrictMaybe (GovActionId (EraCrypto era))
 -> ImpTestM era (GovActionId (EraCrypto era)))
-> StrictMaybe (GovActionId (EraCrypto era))
-> Tree ()
-> ImpTestM era (Tree (GovActionId (EraCrypto era)))
submitGovActionTree StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
submitAction StrictMaybe (GovActionId (EraCrypto era))
p Tree ()
tree =
  forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM Tree (StrictMaybe (GovActionId (EraCrypto era)))
-> ImpTestM
     era
     (GovActionId (EraCrypto era),
      [Tree (StrictMaybe (GovActionId (EraCrypto era)))])
go forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const StrictMaybe (GovActionId (EraCrypto era))
p) Tree ()
tree
  where
    go :: Tree (StrictMaybe (GovActionId (EraCrypto era)))
-> ImpTestM
     era
     (GovActionId (EraCrypto era),
      [Tree (StrictMaybe (GovActionId (EraCrypto era)))])
go (Node StrictMaybe (GovActionId (EraCrypto era))
parent [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
children) = do
      GovActionId (EraCrypto era)
n <- StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
submitAction StrictMaybe (GovActionId (EraCrypto era))
parent
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovActionId (EraCrypto era)
n, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node StrictMaybe (GovActionId (EraCrypto era))
_child [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
subtree) -> forall a. a -> [Tree a] -> Tree a
Node (forall a. a -> StrictMaybe a
SJust GovActionId (EraCrypto era)
n) [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
subtree) [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
children)

submitGovActionForest ::
  (StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era))) ->
  StrictMaybe (GovActionId (EraCrypto era)) ->
  Forest () ->
  ImpTestM era (Forest (GovActionId (EraCrypto era)))
submitGovActionForest :: forall era.
(StrictMaybe (GovActionId (EraCrypto era))
 -> ImpTestM era (GovActionId (EraCrypto era)))
-> StrictMaybe (GovActionId (EraCrypto era))
-> Forest ()
-> ImpTestM era (Forest (GovActionId (EraCrypto era)))
submitGovActionForest StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
submitAction StrictMaybe (GovActionId (EraCrypto era))
p Forest ()
forest =
  forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM Tree (StrictMaybe (GovActionId (EraCrypto era)))
-> ImpTestM
     era
     (GovActionId (EraCrypto era),
      [Tree (StrictMaybe (GovActionId (EraCrypto era)))])
go forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const StrictMaybe (GovActionId (EraCrypto era))
p) Forest ()
forest
  where
    go :: Tree (StrictMaybe (GovActionId (EraCrypto era)))
-> ImpTestM
     era
     (GovActionId (EraCrypto era),
      [Tree (StrictMaybe (GovActionId (EraCrypto era)))])
go (Node StrictMaybe (GovActionId (EraCrypto era))
parent [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
children) = do
      GovActionId (EraCrypto era)
n <- StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
submitAction StrictMaybe (GovActionId (EraCrypto era))
parent
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovActionId (EraCrypto era)
n, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node StrictMaybe (GovActionId (EraCrypto era))
_child [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
subtree) -> forall a. a -> [Tree a] -> Tree a
Node (forall a. a -> StrictMaybe a
SJust GovActionId (EraCrypto era)
n) [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
subtree) [Tree (StrictMaybe (GovActionId (EraCrypto era)))]
children)

enactConstitution ::
  forall era.
  ( ConwayEraImp era
  , HasCallStack
  ) =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
  Constitution era ->
  Credential 'DRepRole (EraCrypto era) ->
  NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)) ->
  ImpTestM era (GovActionId (EraCrypto era))
enactConstitution :: forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId Constitution era
constitution Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers = forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"Enacting constitution" forall a b. (a -> b) -> a -> b
$ do
  let action :: GovAction era
action = forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era -> GovAction era
NewConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId Constitution era
constitution
  GovActionId (EraCrypto era)
govId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
action
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep) GovActionId (EraCrypto era)
govId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers GovActionId (EraCrypto era)
govId
  forall era.
(ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
logRatificationChecks GovActionId (EraCrypto era)
govId
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  Constitution era
enactedConstitution <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL
  Constitution era
enactedConstitution forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId (EraCrypto era)
govId

-- | Asserts that the URL of the current constitution is equal to the given
-- string
constitutionShouldBe :: (HasCallStack, ConwayEraGov era) => String -> ImpTestM era ()
constitutionShouldBe :: forall era.
(HasCallStack, ConwayEraGov era) =>
[Char] -> ImpTestM era ()
constitutionShouldBe [Char]
cUrl = do
  Constitution {constitutionAnchor :: forall era. Constitution era -> Anchor (EraCrypto era)
constitutionAnchor = Anchor {Url
anchorUrl :: Url
anchorUrl :: forall c. Anchor c -> Url
anchorUrl}} <-
    forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL
  Url
anchorUrl forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. HasCallStack => Fail a -> a
errorFail (forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
128 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
cUrl)

expectNumDormantEpochs :: HasCallStack => EpochNo -> ImpTestM era ()
expectNumDormantEpochs :: forall era. HasCallStack => EpochNo -> ImpTestM era ()
expectNumDormantEpochs EpochNo
expected = do
  EpochNo
nd <-
    forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$
      forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL
  EpochNo
nd forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` EpochNo
expected

submitConstitution ::
  forall era.
  ConwayEraImp era =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
  ImpTestM era (GovActionId (EraCrypto era), Constitution era)
submitConstitution :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (GovActionId (EraCrypto era), Constitution era)
submitConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId = do
  Constitution era
constitution <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  let constitutionAction :: GovAction era
constitutionAction =
        forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era -> GovAction era
NewConstitution
          StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId
          Constitution era
constitution
  GovActionId (EraCrypto era)
govActionId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
constitutionAction
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovActionId (EraCrypto era)
govActionId, Constitution era
constitution)

expectDRepNotRegistered ::
  HasCallStack =>
  Credential 'DRepRole (EraCrypto era) ->
  ImpTestM era ()
expectDRepNotRegistered :: forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era ()
expectDRepNotRegistered Credential 'DRepRole (EraCrypto era)
drep = do
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dsMap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL)
  forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
drep Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dsMap forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. Maybe a
Nothing

isDRepExpired ::
  HasCallStack =>
  Credential 'DRepRole (EraCrypto era) ->
  ImpTestM era Bool
isDRepExpired :: forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole (EraCrypto era)
drep = do
  VState era
vState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL
  EpochNo
currentEpoch <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
drep forall a b. (a -> b) -> a -> b
$ VState era
vState forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL of
    Maybe (DRepState (EraCrypto era))
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]
"DRep not found", forall a. Show a => a -> [Char]
show Credential 'DRepRole (EraCrypto era)
drep]
    Just DRepState (EraCrypto era)
drep' ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo forall a. Num a => a -> a -> a
(+) (VState era
vState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL) (DRepState (EraCrypto era)
drep' forall s a. s -> Getting a s a -> a
^. forall c. Lens' (DRepState c) EpochNo
drepExpiryL)
          forall a. Ord a => a -> a -> Bool
< EpochNo
currentEpoch

expectDRepExpiry ::
  HasCallStack =>
  Credential 'DRepRole (EraCrypto era) ->
  EpochNo ->
  ImpTestM era ()
expectDRepExpiry :: forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> EpochNo -> ImpTestM era ()
expectDRepExpiry Credential 'DRepRole (EraCrypto era)
drep EpochNo
expected = do
  Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dsMap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (VState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL
  let ds :: DRepState (EraCrypto era)
ds = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
drep Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dsMap
  forall c. DRepState c -> EpochNo
drepExpiry DRepState (EraCrypto era)
ds forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` EpochNo
expected

expectActualDRepExpiry ::
  HasCallStack =>
  Credential 'DRepRole (EraCrypto era) ->
  EpochNo ->
  ImpTestM era ()
expectActualDRepExpiry :: forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> EpochNo -> ImpTestM era ()
expectActualDRepExpiry Credential 'DRepRole (EraCrypto era)
drep EpochNo
expected = do
  VState era
vState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (VState era)
certVStateL
  let actualDRepExpiry :: EpochNo
actualDRepExpiry = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall era.
Credential 'DRepRole (EraCrypto era) -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential 'DRepRole (EraCrypto era)
drep VState era
vState
  EpochNo
actualDRepExpiry forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` EpochNo
expected

currentProposalsShouldContain ::
  ( HasCallStack
  , ConwayEraGov era
  ) =>
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
currentProposalsShouldContain :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era ()
currentProposalsShouldContain GovActionId (EraCrypto era)
gai =
  forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
currentProposalIds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
[a] -> [a] -> m ()
shouldContain [GovActionId (EraCrypto era)
gai] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

expectCurrentProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectCurrentProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectCurrentProposals = do
  StrictSeq (GovActionId (EraCrypto era))
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
currentProposalIds
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected proposals in current gov state" (Bool -> Bool
not (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq (GovActionId (EraCrypto era))
props))

expectNoCurrentProposals :: (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals :: forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals = do
  Proposals era
proposals <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  case forall era. Proposals era -> StrictSeq (GovActionState era)
proposalsActions Proposals era
proposals of
    StrictSeq (GovActionState era)
Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    StrictSeq (GovActionState era)
xs -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Expected no active proposals, but got:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. ToExpr a => a -> Expr
toExpr StrictSeq (GovActionState era)
xs)

expectPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectPulserProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectPulserProposals = do
  StrictSeq (GovActionId (EraCrypto era))
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
lastEpochProposals
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected proposals in the pulser" (Bool -> Bool
not (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq (GovActionId (EraCrypto era))
props))

expectNoPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals = do
  StrictSeq (GovActionId (EraCrypto era))
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
lastEpochProposals
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected no proposals in the pulser" (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq (GovActionId (EraCrypto era))
props)

currentProposalIds ::
  ConwayEraGov era => ImpTestM era (SSeq.StrictSeq (GovActionId (EraCrypto era)))
currentProposalIds :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
currentProposalIds = forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL)

lastEpochProposals ::
  forall era.
  ConwayEraGov era =>
  ImpTestM era (SSeq.StrictSeq (GovActionId (EraCrypto era)))
lastEpochProposals :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq (GovActionId (EraCrypto era)))
lastEpochProposals =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId @era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingSnapshot era -> StrictSeq (GovActionState era)
psProposals
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES
      ( forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL
      )

pulsingStateSnapshotL :: Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL :: forall era. Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall {era}. DRepPulsingState era -> PulsingSnapshot era
getter forall {era}.
DRepPulsingState era -> PulsingSnapshot era -> DRepPulsingState era
setter
  where
    getter :: DRepPulsingState era -> PulsingSnapshot era
getter (DRComplete PulsingSnapshot era
x RatifyState era
_) = PulsingSnapshot era
x
    getter DRepPulsingState era
state = forall a b. (a, b) -> a
fst (forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
state)
    setter :: DRepPulsingState era -> PulsingSnapshot era -> DRepPulsingState era
setter (DRComplete PulsingSnapshot era
_ RatifyState era
y) PulsingSnapshot era
snap = forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap RatifyState era
y
    setter DRepPulsingState era
state PulsingSnapshot era
snap = forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
state

-- | A legal ProtVer that differs in the minor Version
minorFollow :: ProtVer -> ProtVer
minorFollow :: ProtVer -> ProtVer
minorFollow (ProtVer Version
x Natural
y) = Version -> Natural -> ProtVer
ProtVer Version
x (Natural
y forall a. Num a => a -> a -> a
+ Natural
1)

-- | A legal ProtVer that moves to the next major Version
majorFollow :: ProtVer -> ProtVer
majorFollow :: ProtVer -> ProtVer
majorFollow pv :: ProtVer
pv@(ProtVer Version
x Natural
_) = case forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion Version
x of
  Just Version
x' -> Version -> Natural -> ProtVer
ProtVer Version
x' Natural
0
  Maybe Version
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"The last major version can't be incremented. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ProtVer
pv)

-- | An illegal ProtVer that skips 3 minor versions
cantFollow :: ProtVer -> ProtVer
cantFollow :: ProtVer -> ProtVer
cantFollow (ProtVer Version
x Natural
y) = Version -> Natural -> ProtVer
ProtVer Version
x (Natural
y forall a. Num a => a -> a -> a
+ Natural
3)

whenPostBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap :: forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ImpTestM era ()
a = do
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtVer -> Bool
HardForks.bootstrapPhase ProtVer
pv) ImpTestM era ()
a

ifBootstrap :: EraGov era => ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap :: forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap ImpTestM era a
inBootstrap ImpTestM era a
outOfBootstrap = do
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  if ProtVer -> Bool
HardForks.bootstrapPhase ProtVer
pv then ImpTestM era a
inBootstrap else ImpTestM era a
outOfBootstrap

submitYesVoteCCs_ ::
  forall era f.
  (ConwayEraImp era, Foldable f) =>
  f (Credential 'HotCommitteeRole (EraCrypto era)) ->
  GovActionId (EraCrypto era) ->
  ImpTestM era ()
submitYesVoteCCs_ :: forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ f (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers GovActionId (EraCrypto era)
govId =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Credential 'HotCommitteeRole (EraCrypto era)
c -> forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
c) GovActionId (EraCrypto era)
govId) f (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers

submitUpdateCommittee ::
  ConwayEraImp era =>
  -- | Set the parent. When Nothing is supplied latest parent will be used.
  Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era)) ->
  -- | CC members to remove
  Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) ->
  -- | CC members to add
  [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)] ->
  UnitInterval ->
  ImpTestM era (GovActionId (EraCrypto era))
submitUpdateCommittee :: forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (GovActionId (EraCrypto era))
submitUpdateCommittee Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent Set (Credential 'ColdCommitteeRole (EraCrypto era))
ccsToRemove [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
ccsToAdd UnitInterval
threshold = do
  NewEpochState era
nes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a. a -> a
id
  let
    curEpochNo :: EpochNo
curEpochNo = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
    rootCommittee :: PRoot (GovPurposeId 'CommitteePurpose era)
rootCommittee = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (ConwayGovState era) (Proposals era)
cgsProposalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL
    parent :: StrictMaybe (GovPurposeId 'CommitteePurpose era)
parent = forall a. a -> Maybe a -> a
fromMaybe (forall a. PRoot a -> StrictMaybe a
prRoot PRoot (GovPurposeId 'CommitteePurpose era)
rootCommittee) Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent
    newCommitteMembers :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
newCommitteMembers =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
lifetime) | (Credential 'ColdCommitteeRole (EraCrypto era)
cc, EpochInterval
lifetime) <- [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
ccsToAdd]
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
parent Set (Credential 'ColdCommitteeRole (EraCrypto era))
ccsToRemove Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
newCommitteMembers UnitInterval
threshold

expectCommitteeMemberPresence ::
  (HasCallStack, ConwayEraGov era) => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberPresence :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole (EraCrypto era)
cc = do
  SJust Committee era
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool ([Char]
"Expected Committee Member: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole (EraCrypto era)
cc forall a. [a] -> [a] -> [a]
++ [Char]
" to be present in the committee") forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole (EraCrypto era)
cc (Committee era
committee forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Committee era)
  (Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo)
committeeMembersL)

expectCommitteeMemberAbsence ::
  (HasCallStack, ConwayEraGov era) => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberAbsence :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole (EraCrypto era)
cc = do
  SJust Committee era
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool ([Char]
"Expected Committee Member: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole (EraCrypto era)
cc forall a. [a] -> [a] -> [a]
++ [Char]
" to be absent from the committee") forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'ColdCommitteeRole (EraCrypto era)
cc (Committee era
committee forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Committee era)
  (Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo)
committeeMembersL)

donateToTreasury :: ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury :: forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury Coin
amount =
  forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn ([Char]
"Donation to treasury in the amount of: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Coin
amount) forall a b. (a -> b) -> a -> b
$ do
    Coin
treasuryStart <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' AccountState Coin
asTreasuryL
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
amount)
    Coin
treasuryEndEpoch0 <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' AccountState Coin
asTreasuryL
    -- Actual donation happens on the epoch boundary
    Coin
treasuryStart forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Coin
treasuryEndEpoch0
    forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    Coin
treasuryEndEpoch1 <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' AccountState Coin
asTreasuryL
    Coin
treasuryEndEpoch1 forall t. Val t => t -> t -> t
<-> Coin
treasuryStart forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Coin
amount

expectMembers ::
  (HasCallStack, ConwayEraGov era) =>
  Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) -> ImpTestM era ()
expectMembers :: forall era.
(HasCallStack, ConwayEraGov era) =>
Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> ImpTestM era ()
expectMembers Set (Credential 'ColdCommitteeRole (EraCrypto era))
expKhs = do
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  let members :: Set (Credential 'ColdCommitteeRole (EraCrypto era))
members = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
  forall a era.
NFData a =>
[Char] -> ImpTestM era a -> ImpTestM era a
impAnn [Char]
"Expecting committee members" forall a b. (a -> b) -> a -> b
$ Set (Credential 'ColdCommitteeRole (EraCrypto era))
members forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Set (Credential 'ColdCommitteeRole (EraCrypto era))
expKhs

showConwayTxBalance ::
  ( EraUTxO era
  , ConwayEraTxBody era
  , Tx era ~ AlonzoTx era
  ) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  AlonzoTx era ->
  String
showConwayTxBalance :: forall era.
(EraUTxO era, ConwayEraTxBody era, Tx era ~ AlonzoTx era) =>
PParams era -> CertState era -> UTxO era -> AlonzoTx era -> [Char]
showConwayTxBalance PParams era
pp CertState era
certState UTxO era
utxo AlonzoTx era
tx =
  [[Char]] -> [Char]
unlines
    [ [Char]
"Consumed:   \t"
    , [Char]
"\tInputs:     \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall t. Val t => t -> Coin
coin Value era
inputs)
    , -- , "Refunds:    \t" <> show refunds
      [Char]
"\tWithdrawals \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Coin
withdrawals
    , [Char]
"\tTotal:      \t" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody)
    , [Char]
""
    , [Char]
"Produced:  \t"
    , [Char]
"\tOutputs:   \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL))
    , [Char]
"\tDonations: \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL)
    , [Char]
"\tDeposits:  \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Coin
getTotalDepositsTxBody PParams era
pp KeyHash 'StakePool (EraCrypto era) -> Bool
isRegPoolId TxBody era
txBody)
    , [Char]
"\tFees:      \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL)
    , [Char]
"\tTotal:     \t" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState TxBody era
txBody)
    ]
  where
    -- lookupStakingDeposit c = certState ^. certPStateL . psStakePoolParamsL
    -- lookupDRepDeposit c = undefined
    txBody :: TxBody era
txBody = AlonzoTx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    inputs :: Value era
inputs = forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. UTxO era -> Set (TxIn (EraCrypto era)) -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL))
    -- refunds = getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody
    isRegPoolId :: KeyHash 'StakePool (EraCrypto era) -> Bool
isRegPoolId = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (PState era)
certPStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (PState era)
  (Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psStakePoolParamsL))
    withdrawals :: Coin
withdrawals = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Withdrawals c -> Map (RewardAcnt c) Coin
unWithdrawals forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL

logConwayTxBalance ::
  ( EraUTxO era
  , EraGov era
  , ConwayEraTxBody era
  , Tx era ~ AlonzoTx era
  ) =>
  AlonzoTx era ->
  ImpTestM era ()
logConwayTxBalance :: forall era.
(EraUTxO era, EraGov era, ConwayEraTxBody era,
 Tx era ~ AlonzoTx era) =>
AlonzoTx era -> ImpTestM era ()
logConwayTxBalance AlonzoTx era
tx = do
  PParams era
pp <- forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams forall a. a -> a
id
  CertState era
certState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL
  UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
  forall era. HasCallStack => [Char] -> ImpTestM era ()
logString forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ConwayEraTxBody era, Tx era ~ AlonzoTx era) =>
PParams era -> CertState era -> UTxO era -> AlonzoTx era -> [Char]
showConwayTxBalance PParams era
pp CertState era
certState UTxO era
utxo AlonzoTx era
tx