{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Shelley.ImpTest (
  ImpTestM,
  LedgerSpec,
  SomeSTSEvent (..),
  ImpTestState,
  ImpTestEnv (..),
  ImpException (..),
  ShelleyEraImp (..),
  PlutusArgs,
  ScriptTestContext,
  impWitsVKeyNeeded,
  modifyPrevPParams,
  passEpoch,
  passNEpochs,
  passNEpochsChecking,
  passTick,
  freshKeyAddr,
  freshKeyAddr_,
  freshKeyHash,
  freshKeyPair,
  lookupKeyPair,
  freshByronKeyHash,
  freshBootstapAddress,
  lookupByronKeyPair,
  freshSafeHash,
  freshKeyHashVRF,
  submitTx,
  submitTx_,
  submitTxAnn,
  submitTxAnn_,
  submitFailingTx,
  submitFailingTxM,
  trySubmitTx,
  modifyNES,
  getProtVer,
  getsNES,
  getUTxO,
  impAddNativeScript,
  impAnn,
  impAnnDoc,
  impLogToExpr,
  runImpRule,
  tryRunImpRule,
  tryRunImpRuleNoAssertions,
  delegateStake,
  registerRewardAccount,
  registerStakeCredential,
  getRewardAccountFor,
  tryLookupReward,
  lookupReward,
  poolParams,
  registerPool,
  registerPoolWithRewardAccount,
  registerAndRetirePoolToMakeReward,
  getRewardAccountAmount,
  shelleyFixupTx,
  lookupImpRootTxOut,
  sendValueTo,
  sendCoinTo,
  expectUTxOContent,
  expectRegisteredRewardAddress,
  expectNotRegisteredRewardAddress,
  expectTreasury,
  disableTreasuryExpansion,
  updateAddrTxWits,
  addNativeScriptTxWits,
  addRootTxIn,
  fixupTxOuts,
  fixupFees,
  fixupAuxDataHash,
  impGetNativeScript,
  impLookupUTxO,
  defaultInitNewEpochState,
  defaultInitImpTestState,
  impEraStartEpochNo,
  impSetSeed,
  modifyImpInitProtVer,

  -- * Logging
  Doc,
  AnsiStyle,
  logDoc,
  logText,
  logString,
  logToExpr,
  logStakeDistr,
  logFeeMismatch,

  -- * Combinators
  withCustomFixup,
  withFixup,
  withNoFixup,
  withPostFixup,
  withPreFixup,
  withCborRoundTripFailures,
  impNESL,
  impGlobalsL,
  impLastTickG,
  impKeyPairsG,
  impNativeScriptsG,
  produceScript,
  advanceToPointOfNoReturn,

  -- * ImpSpec re-exports
  ImpM,
  ImpInit,
) where

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.UTxO as Byron (empty)
import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
import Cardano.Crypto.Hash (HashAlgorithm)
import Cardano.Crypto.Hash.Blake2b (Blake2b_224)
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Address (
  Addr (..),
  BootstrapAddress (..),
  RewardAccount (..),
  bootstrapKeyHash,
 )
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Block (Block)
import Cardano.Ledger.CertState (certDStateL, dsUnifiedL)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..))
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  Hash,
  KeyHash,
  KeyRole (..),
  KeyRoleVRF (..),
  VRFVerKeyHash,
  asWitness,
  bootstrapWitKeyHash,
  hashKey,
  makeBootstrapWitness,
  witVKeyHash,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash, extractHash)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo)
import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Genesis (
  ShelleyGenesis (..),
  describeValidationErr,
  fromNominalDiffTimeMicro,
  mkShelleyGlobals,
  validateGenesis,
 )
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  NewEpochState (..),
  StashedAVVMAddresses,
  asTreasuryL,
  consumed,
  curPParamsEpochStateL,
  epochStateIncrStakeDistrL,
  epochStateUMapL,
  esAccountStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  prevPParamsEpochStateL,
  produced,
  utxosDonationL,
  utxosUtxoL,
 )
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  LedgerEnv (..),
  ShelleyBbodyState,
  epochFromSlot,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext)
import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn)
import Cardano.Ledger.Tools (
  calcMinFeeTxNativeScriptWits,
  setMinCoinTxOut,
 )
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UMap as UMap
import Cardano.Ledger.UTxO (
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO (..),
  txinLookup,
 )
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader (..), asks)
import Control.Monad.State.Strict (MonadState (..), evalStateT, gets, modify)
import Control.Monad.Trans.Fail.String (errorFail)
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Writer.Class (MonadWriter (..))
import Control.State.Transition (STS (..), TRC (..), applySTSOptsEither)
import Control.State.Transition.Extended (
  ApplySTSOpts (..),
  AssertionPolicy (..),
  SingEP (..),
  ValidationPolicy (..),
 )
import Data.Bifunctor (first)
import Data.Coerce (coerce)
import Data.Data (Proxy (..), type (:~:) (..))
import Data.Default (Default (..))
import Data.Foldable (toList, traverse_)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
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.Time.Format.ISO8601 (iso8601ParseM)
import Data.TreeDiff (ansiWlExpr)
import Data.Type.Equality (TestEquality (..))
import Data.Void
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Lens.Micro (Lens', SimpleGetter, lens, to, (%~), (&), (.~), (<>~), (^.))
import Lens.Micro.Mtl (use, view, (%=), (+=), (.=))
import Numeric.Natural (Natural)
import Prettyprinter (Doc)
import Prettyprinter.Render.Terminal (AnsiStyle)
import qualified System.Random.Stateful as R
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation)
import Test.Cardano.Ledger.Core.KeyPair (
  ByronKeyPair (..),
  KeyPair (..),
  mkAddr,
  mkWitnessesVKey,
 )
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext)
import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..))
import Test.Cardano.Slotting.Numeric ()
import Test.ImpSpec
import Type.Reflection (Typeable, typeOf)
import UnliftIO.Exception (evaluateDeep)

type ImpTestM era = ImpM (LedgerSpec era)

data LedgerSpec era

instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where
  type ImpSpecEnv (LedgerSpec era) = ImpTestEnv era
  type ImpSpecState (LedgerSpec era) = ImpTestState era
  impInitIO :: QCGen -> IO (ImpInit (LedgerSpec era))
impInitIO QCGen
qcGen = do
    IOGenM QCGen
ioGen <- forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
R.newIOGenM QCGen
qcGen
    ImpTestState era
initState <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (ImpTestState era)
initImpTestState IOGenM QCGen
ioGen) (forall a. Monoid a => a
mempty :: ImpPrepState (EraCrypto era))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      ImpInit
        { impInitEnv :: ImpSpecEnv (LedgerSpec era)
impInitEnv =
            ImpTestEnv
              { iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx
              , iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
True
              }
        , impInitState :: ImpSpecState (LedgerSpec era)
impInitState = ImpTestState era
initState
        }

  -- There is an important step here of running TICK rule. This is necessary as a final
  -- step of `era` initialization, because on the very first TICK of an era the
  -- `futurePParams` are applied and the epoch number is updated to the first epoch
  -- number of the current era
  impPrepAction :: ImpM (LedgerSpec era) ()
impPrepAction = forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick

data SomeSTSEvent era
  = forall (rule :: Symbol).
    ( Typeable (Event (EraRule rule era))
    , Eq (Event (EraRule rule era))
    , ToExpr (Event (EraRule rule era))
    ) =>
    SomeSTSEvent (Event (EraRule rule era))

instance Eq (SomeSTSEvent era) where
  SomeSTSEvent Event (EraRule rule era)
x == :: SomeSTSEvent era -> SomeSTSEvent era -> Bool
== SomeSTSEvent Event (EraRule rule era)
y
    | Just Event (EraRule rule era) :~: Event (EraRule rule era)
Refl <- forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
x) (forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
y) = Event (EraRule rule era)
x forall a. Eq a => a -> a -> Bool
== Event (EraRule rule era)
y
    | Bool
otherwise = Bool
False

instance ToExpr (SomeSTSEvent era) where
  toExpr :: SomeSTSEvent era -> Expr
toExpr (SomeSTSEvent Event (EraRule rule era)
ev) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"SomeSTSEvent" [forall a. ToExpr a => a -> Expr
toExpr Event (EraRule rule era)
ev]

data ImpTestState era = ImpTestState
  { forall era. ImpTestState era -> NewEpochState era
impNES :: !(NewEpochState era)
  , forall era. ImpTestState era -> TxIn (EraCrypto era)
impRootTxIn :: !(TxIn (EraCrypto era))
  , forall era.
ImpTestState era
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
impKeyPairs :: !(Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))
  , forall era.
ImpTestState era
-> Map (BootstrapAddress (EraCrypto era)) ByronKeyPair
impByronKeyPairs :: !(Map (BootstrapAddress (EraCrypto era)) ByronKeyPair)
  , forall era.
ImpTestState era
-> Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts :: !(Map (ScriptHash (EraCrypto era)) (NativeScript era))
  , forall era. ImpTestState era -> SlotNo
impLastTick :: !SlotNo
  , forall era. ImpTestState era -> Globals
impGlobals :: !Globals
  , forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents :: [SomeSTSEvent era]
  }

-- | This is a preliminary state that is used to prepare the actual `ImpTestState`
data ImpPrepState c = ImpPrepState
  { forall c.
ImpPrepState c -> Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs :: !(Map (KeyHash 'Witness c) (KeyPair 'Witness c))
  , forall c. ImpPrepState c -> Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs :: !(Map (BootstrapAddress c) ByronKeyPair)
  }

instance Semigroup (ImpPrepState c) where
  <> :: ImpPrepState c -> ImpPrepState c -> ImpPrepState c
(<>) ImpPrepState c
ips1 ImpPrepState c
ips2 =
    ImpPrepState
      { impPrepKeyPairs :: Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs = forall c.
ImpPrepState c -> Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs ImpPrepState c
ips1 forall a. Semigroup a => a -> a -> a
<> forall c.
ImpPrepState c -> Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs ImpPrepState c
ips2
      , impPrepByronKeyPairs :: Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs = forall c. ImpPrepState c -> Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs ImpPrepState c
ips1 forall a. Semigroup a => a -> a -> a
<> forall c. ImpPrepState c -> Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs ImpPrepState c
ips2
      }

instance Monoid (ImpPrepState c) where
  mempty :: ImpPrepState c
mempty =
    ImpPrepState
      { impPrepKeyPairs :: Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs = forall a. Monoid a => a
mempty
      , impPrepByronKeyPairs :: Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs = forall a. Monoid a => a
mempty
      }

class Crypto c => HasKeyPairs t c | t -> c where
  keyPairsL :: Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
  keyPairsByronL :: Lens' t (Map (BootstrapAddress c) ByronKeyPair)

instance (Era era, c ~ EraCrypto era) => HasKeyPairs (ImpTestState era) c where
  keyPairsL :: Lens'
  (ImpTestState era) (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
keyPairsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ImpTestState era
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
impKeyPairs (\ImpTestState era
x Map (KeyHash 'Witness c) (KeyPair 'Witness c)
y -> ImpTestState era
x {impKeyPairs :: Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
impKeyPairs = Map (KeyHash 'Witness c) (KeyPair 'Witness c)
y})
  keyPairsByronL :: Lens' (ImpTestState era) (Map (BootstrapAddress c) ByronKeyPair)
keyPairsByronL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ImpTestState era
-> Map (BootstrapAddress (EraCrypto era)) ByronKeyPair
impByronKeyPairs (\ImpTestState era
x Map (BootstrapAddress c) ByronKeyPair
y -> ImpTestState era
x {impByronKeyPairs :: Map (BootstrapAddress (EraCrypto era)) ByronKeyPair
impByronKeyPairs = Map (BootstrapAddress c) ByronKeyPair
y})

instance Crypto c => HasKeyPairs (ImpPrepState c) c where
  keyPairsL :: Lens'
  (ImpPrepState c) (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
keyPairsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
ImpPrepState c -> Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs (\ImpPrepState c
x Map (KeyHash 'Witness c) (KeyPair 'Witness c)
y -> ImpPrepState c
x {impPrepKeyPairs :: Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs = Map (KeyHash 'Witness c) (KeyPair 'Witness c)
y})
  keyPairsByronL :: Lens' (ImpPrepState c) (Map (BootstrapAddress c) ByronKeyPair)
keyPairsByronL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. ImpPrepState c -> Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs (\ImpPrepState c
x Map (BootstrapAddress c) ByronKeyPair
y -> ImpPrepState c
x {impPrepByronKeyPairs :: Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs = Map (BootstrapAddress c) ByronKeyPair
y})

impGlobalsL :: Lens' (ImpTestState era) Globals
impGlobalsL :: forall era. Lens' (ImpTestState era) Globals
impGlobalsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Globals
impGlobals (\ImpTestState era
x Globals
y -> ImpTestState era
x {impGlobals :: Globals
impGlobals = Globals
y})

impNESL :: Lens' (ImpTestState era) (NewEpochState era)
impNESL :: forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> NewEpochState era
impNES (\ImpTestState era
x NewEpochState era
y -> ImpTestState era
x {impNES :: NewEpochState era
impNES = NewEpochState era
y})

impLastTickL :: Lens' (ImpTestState era) SlotNo
impLastTickL :: forall era. Lens' (ImpTestState era) SlotNo
impLastTickL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> SlotNo
impLastTick (\ImpTestState era
x SlotNo
y -> ImpTestState era
x {impLastTick :: SlotNo
impLastTick = SlotNo
y})

impLastTickG :: SimpleGetter (ImpTestState era) SlotNo
impLastTickG :: forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG = forall era. Lens' (ImpTestState era) SlotNo
impLastTickL

impRootTxInL :: Lens' (ImpTestState era) (TxIn (EraCrypto era))
impRootTxInL :: forall era. Lens' (ImpTestState era) (TxIn (EraCrypto era))
impRootTxInL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> TxIn (EraCrypto era)
impRootTxIn (\ImpTestState era
x TxIn (EraCrypto era)
y -> ImpTestState era
x {impRootTxIn :: TxIn (EraCrypto era)
impRootTxIn = TxIn (EraCrypto era)
y})

impKeyPairsG ::
  SimpleGetter
    (ImpTestState era)
    (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))
impKeyPairsG :: forall era.
SimpleGetter
  (ImpTestState era)
  (Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era)))
impKeyPairsG = forall s a. (s -> a) -> SimpleGetter s a
to forall era.
ImpTestState era
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
impKeyPairs

impNativeScriptsL :: Lens' (ImpTestState era) (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsL :: forall era.
Lens'
  (ImpTestState era)
  (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ImpTestState era
-> Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts (\ImpTestState era
x Map (ScriptHash (EraCrypto era)) (NativeScript era)
y -> ImpTestState era
x {impNativeScripts :: Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts = Map (ScriptHash (EraCrypto era)) (NativeScript era)
y})

impNativeScriptsG ::
  SimpleGetter (ImpTestState era) (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsG :: forall era.
SimpleGetter
  (ImpTestState era)
  (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsG = forall era.
Lens'
  (ImpTestState era)
  (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsL

impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL :: forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents (\ImpTestState era
x [SomeSTSEvent era]
y -> ImpTestState era
x {impEvents :: [SomeSTSEvent era]
impEvents = [SomeSTSEvent era]
y})

class
  ( EraGov era
  , EraUTxO era
  , EraTxOut era
  , EraPParams era
  , ShelleyEraTxCert era
  , ShelleyEraScript era
  , ToExpr (Tx era)
  , NFData (Tx era)
  , ToExpr (TxBody era)
  , ToExpr (TxOut era)
  , ToExpr (Value era)
  , ToExpr (PParams era)
  , ToExpr (PParamsHKD Identity era)
  , ToExpr (PParamsHKD StrictMaybe era)
  , Show (NewEpochState era)
  , ToExpr (NewEpochState era)
  , ToExpr (GovState era)
  , Eq (StashedAVVMAddresses era)
  , Show (StashedAVVMAddresses era)
  , ToExpr (StashedAVVMAddresses era)
  , NFData (StashedAVVMAddresses era)
  , Default (StashedAVVMAddresses era)
  , -- For BBODY rule
    STS (EraRule "BBODY" era)
  , BaseM (EraRule "BBODY" era) ~ ShelleyBase
  , Environment (EraRule "BBODY" era) ~ BbodyEnv era
  , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
  , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , -- For the LEDGER rule
    STS (EraRule "LEDGER" era)
  , BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , Signal (EraRule "LEDGER" era) ~ Tx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Show (PredicateFailure (EraRule "LEDGER" era))
  , ToExpr (PredicateFailure (EraRule "LEDGER" era))
  , NFData (PredicateFailure (EraRule "LEDGER" era))
  , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
  , DecCBOR (PredicateFailure (EraRule "LEDGER" era))
  , EraRuleEvent "LEDGER" era ~ Event (EraRule "LEDGER" era)
  , Eq (EraRuleEvent "LEDGER" era)
  , ToExpr (EraRuleEvent "LEDGER" era)
  , NFData (EraRuleEvent "LEDGER" era)
  , Typeable (EraRuleEvent "LEDGER" era)
  , -- For the TICK rule
    STS (EraRule "TICK" era)
  , BaseM (EraRule "TICK" era) ~ ShelleyBase
  , Signal (EraRule "TICK" era) ~ SlotNo
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Environment (EraRule "TICK" era) ~ ()
  , NFData (PredicateFailure (EraRule "TICK" era))
  , EraRuleEvent "TICK" era ~ Event (EraRule "TICK" era)
  , Eq (EraRuleEvent "TICK" era)
  , ToExpr (EraRuleEvent "TICK" era)
  , NFData (EraRuleEvent "TICK" era)
  , Typeable (EraRuleEvent "TICK" era)
  , ToExpr (PredicateFailure (EraRule "UTXOW" era))
  , -- Necessary Crypto
    DSIGN (EraCrypto era) ~ Ed25519DSIGN
  , NFData (VerKeyDSIGN (DSIGN (EraCrypto era)))
  , VRF.VRFAlgorithm (VRF (EraCrypto era))
  , HashAlgorithm (HASH (EraCrypto era))
  , DSIGNAlgorithm (DSIGN (EraCrypto era))
  , Signable (DSIGN (EraCrypto era)) (Hash (EraCrypto era) EraIndependentTxBody)
  , ADDRHASH (EraCrypto era) ~ Blake2b_224
  ) =>
  ShelleyEraImp era
  where
  initGenesis ::
    (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m, MonadFail m) =>
    m (Genesis era)
  default initGenesis ::
    (Monad m, Genesis era ~ NoGenesis era) =>
    m (Genesis era)
  initGenesis = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall era. NoGenesis era
NoGenesis

  initNewEpochState ::
    (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m, MonadFail m) =>
    m (NewEpochState era)
  default initNewEpochState ::
    ( HasKeyPairs s (EraCrypto era)
    , MonadState s m
    , HasStatefulGen g m
    , MonadFail m
    , ShelleyEraImp (PreviousEra era)
    , TranslateEra era NewEpochState
    , TranslationError era NewEpochState ~ Void
    , TranslationContext era ~ Genesis era
    , EraCrypto era ~ EraCrypto (PreviousEra era)
    ) =>
    m (NewEpochState era)
  initNewEpochState = forall era g s (m :: * -> *).
(MonadState s m, HasKeyPairs s (EraCrypto era), HasStatefulGen g m,
 MonadFail m, ShelleyEraImp era, ShelleyEraImp (PreviousEra era),
 TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era,
 EraCrypto era ~ EraCrypto (PreviousEra era)) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState forall a. a -> a
id

  initImpTestState ::
    ( HasKeyPairs s (EraCrypto era)
    , MonadState s m
    , HasStatefulGen g m
    , MonadFail m
    ) =>
    m (ImpTestState era)
  initImpTestState = forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
initNewEpochState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era s g (m :: * -> *).
(EraGov era, EraTxOut era, DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 ADDRHASH (EraCrypto era) ~ Blake2b_224,
 HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m,
 MonadFail m) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState

  -- | Try to find a sufficient number of KeyPairs that would satisfy a native script.
  -- Whenever script can't be satisfied, Nothing is returned
  impSatisfyNativeScript ::
    -- | Set of Witnesses that have already been satisfied
    Set.Set (KeyHash 'Witness (EraCrypto era)) ->
    -- | The transaction body that the script will be applied to
    TxBody era ->
    NativeScript era ->
    ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))

  -- | This modifer should change not only the current PParams, but also the future
  -- PParams. If the future PParams are not updated, then they will overwrite the
  -- mofication of the current PParams at the next epoch.
  modifyPParams ::
    (PParams era -> PParams era) ->
    ImpTestM era ()
  modifyPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES 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 s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

  fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era)

defaultInitNewEpochState ::
  forall era g s m.
  ( MonadState s m
  , HasKeyPairs s (EraCrypto era)
  , HasStatefulGen g m
  , MonadFail m
  , ShelleyEraImp era
  , ShelleyEraImp (PreviousEra era)
  , TranslateEra era NewEpochState
  , TranslationError era NewEpochState ~ Void
  , TranslationContext era ~ Genesis era
  , EraCrypto era ~ EraCrypto (PreviousEra era)
  ) =>
  (NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)) ->
  m (NewEpochState era)
defaultInitNewEpochState :: forall era g s (m :: * -> *).
(MonadState s m, HasKeyPairs s (EraCrypto era), HasStatefulGen g m,
 MonadFail m, ShelleyEraImp era, ShelleyEraImp (PreviousEra era),
 TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era,
 EraCrypto era ~ EraCrypto (PreviousEra era)) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)
modifyPrevEraNewEpochState = do
  Genesis era
genesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @era
  NewEpochState (PreviousEra era)
nes <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
initNewEpochState @(PreviousEra era)
  let majProtVer :: Version
majProtVer = forall era. Era era => Version
eraProtVerLow @era
      -- We need to set the protocol version for the current era and for debugging
      -- purposes we start the era at the epoch number that matches the protocol version
      -- times a 100. However, because this is the NewEpochState from the previous era, we
      -- initialize it with futurePParams preset and epoch number that is one behind the
      -- beginning of this era. Note that all imp tests will start with a TICK, in order
      -- for theses changes to be applied.
      prevEraNewEpochState :: NewEpochState (PreviousEra era)
prevEraNewEpochState =
        NewEpochState (PreviousEra 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 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
majProtVer Natural
0
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) EpochNo
nesELL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Enum a => a -> a
pred (forall era. Era era => EpochNo
impEraStartEpochNo @era)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra' Genesis era
genesis forall a b. (a -> b) -> a -> b
$ NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)
modifyPrevEraNewEpochState NewEpochState (PreviousEra era)
prevEraNewEpochState

-- | For debugging purposes we start the era at the epoch number that matches the starting
-- protocol version for the era times a 100
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo = Word64 -> EpochNo
EpochNo (forall i. Integral i => Version -> i
getVersion Version
majProtVer forall a. Num a => a -> a -> a
* Word64
100)
  where
    majProtVer :: Version
majProtVer = forall era. Era era => Version
eraProtVerLow @era

defaultInitImpTestState ::
  forall era s g m.
  ( EraGov era
  , EraTxOut era
  , DSIGN (EraCrypto era) ~ Ed25519DSIGN
  , ADDRHASH (EraCrypto era) ~ Blake2b_224
  , HasKeyPairs s (EraCrypto era)
  , MonadState s m
  , HasStatefulGen g m
  , MonadFail m
  ) =>
  NewEpochState era ->
  m (ImpTestState era)
defaultInitImpTestState :: forall era s g (m :: * -> *).
(EraGov era, EraTxOut era, DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 ADDRHASH (EraCrypto era) ~ Blake2b_224,
 HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen g m,
 MonadFail m) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState NewEpochState era
nes = do
  ShelleyGenesis (EraCrypto era)
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @(ShelleyEra (EraCrypto era))
  KeyHash 'Payment (EraCrypto era)
rootKeyHash <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  let
    rootAddr :: Addr (EraCrypto era)
    rootAddr :: Addr (EraCrypto era)
rootAddr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Payment (EraCrypto era)
rootKeyHash) forall c. StakeReference c
StakeRefNull
    rootTxOut :: TxOut era
    rootTxOut :: TxOut era
rootTxOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
rootAddr forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject Coin
rootCoin
    rootCoin :: Coin
rootCoin = Integer -> Coin
Coin (forall a. Integral a => a -> Integer
toInteger (forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply ShelleyGenesis (EraCrypto era)
shelleyGenesis))
    rootTxIn :: TxIn (EraCrypto era)
    rootTxIn :: TxIn (EraCrypto era)
rootTxIn = forall c. TxId c -> TxIx -> TxIn c
TxIn (forall c. Crypto c => Int -> TxId c
mkTxId Int
0) forall a. Bounded a => a
minBound
    nesWithRoot :: NewEpochState era
nesWithRoot =
      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. 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 a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO (forall k a. k -> a -> Map k a
Map.singleton TxIn (EraCrypto era)
rootTxIn TxOut era
rootTxOut)
  s
prepState <- forall s (m :: * -> *). MonadState s m => m s
get
  let epochInfoE :: EpochInfo (Either Text)
epochInfoE =
        forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
          (forall c. ShelleyGenesis c -> EpochSize
sgEpochLength ShelleyGenesis (EraCrypto era)
shelleyGenesis)
          (NominalDiffTime -> SlotLength
mkSlotLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro forall a b. (a -> b) -> a -> b
$ forall c. ShelleyGenesis c -> NominalDiffTimeMicro
sgSlotLength ShelleyGenesis (EraCrypto era)
shelleyGenesis)
      globals :: Globals
globals = forall c. ShelleyGenesis c -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals ShelleyGenesis (EraCrypto era)
shelleyGenesis EpochInfo (Either Text)
epochInfoE
      epochNo :: EpochNo
epochNo = NewEpochState era
nesWithRoot forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
      slotNo :: SlotNo
slotNo = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (HasCallStack => EpochInfo Identity -> EpochNo -> ShelleyBase SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo) Globals
globals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    ImpTestState
      { impNES :: NewEpochState era
impNES = NewEpochState era
nesWithRoot
      , impRootTxIn :: TxIn (EraCrypto era)
impRootTxIn = TxIn (EraCrypto era)
rootTxIn
      , impKeyPairs :: Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
impKeyPairs = s
prepState forall s a. s -> Getting a s a -> a
^. forall t c.
HasKeyPairs t c =>
Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
keyPairsL
      , impByronKeyPairs :: Map (BootstrapAddress (EraCrypto era)) ByronKeyPair
impByronKeyPairs = s
prepState forall s a. s -> Getting a s a -> a
^. forall t c.
HasKeyPairs t c =>
Lens' t (Map (BootstrapAddress c) ByronKeyPair)
keyPairsByronL
      , impNativeScripts :: Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts = forall a. Monoid a => a
mempty
      , impLastTick :: SlotNo
impLastTick = SlotNo
slotNo
      , impGlobals :: Globals
impGlobals = Globals
globals
      , impEvents :: [SomeSTSEvent era]
impEvents = forall a. Monoid a => a
mempty
      }

modifyImpInitProtVer ::
  forall era.
  ShelleyEraImp era =>
  Version ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer :: forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer Version
ver =
  forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitState :: ImpSpecState (LedgerSpec era)
impInitState =
          forall t. ImpInit t -> ImpSpecState t
impInitState ImpInit (LedgerSpec era)
impInit
            forall a b. a -> (a -> b) -> 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. 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) ProtVer
ppProtocolVersionL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer Version
ver Natural
0
      }

impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv :: forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
nes = do
  SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  EpochNo
epochNo <- forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase forall a b. (a -> b) -> a -> b
$ SlotNo -> Reader Globals EpochNo
epochFromSlot SlotNo
slotNo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LedgerEnv
      { ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
slotNo
      , ledgerEpochNo :: Maybe EpochNo
ledgerEpochNo = forall a. a -> Maybe a
Just EpochNo
epochNo
      , ledgerPp :: PParams era
ledgerPp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. 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
      , ledgerIx :: TxIx
ledgerIx = Word64 -> TxIx
TxIx Word64
0
      , ledgerAccount :: AccountState
ledgerAccount = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. 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
      , ledgerMempool :: Bool
ledgerMempool = Bool
False
      }

-- | Modify the previous PParams in the current state with the given function. For current
-- and future PParams, use `modifyPParams`
modifyPrevPParams ::
  EraGov era =>
  (PParams era -> PParams era) ->
  ImpTestM era ()
modifyPrevPParams :: forall era.
EraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPrevPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES 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)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

-- | Logs the current stake distribution
logStakeDistr :: HasCallStack => ImpTestM era ()
logStakeDistr :: forall era. HasCallStack => ImpTestM era ()
logStakeDistr = do
  Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
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)
  (Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin))
epochStateIncrStakeDistrL
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Stake distr: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stakeDistr

mkTxId :: Crypto c => Int -> TxId c
mkTxId :: forall c. Crypto c => Int -> TxId c
mkTxId Int
idx = forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
idx)

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash c EraIndependentTxBody)
  , ShelleyEraScript (ShelleyEra c)
  ) =>
  ShelleyEraImp (ShelleyEra c)
  where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s (EraCrypto (ShelleyEra c)), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis (ShelleyEra c))
initGenesis = do
    let
      gen :: ShelleyGenesis c
gen =
        ShelleyGenesis
          { sgSystemStart :: UTCTime
sgSystemStart = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t.
(MonadFail m, ISO8601 t) =>
ConstructorName -> m t
iso8601ParseM ConstructorName
"2017-09-23T21:44:51Z"
          , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123456 -- Mainnet value: 764824073
          , sgNetworkId :: Network
sgNetworkId = Network
Testnet
          , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
20 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100 -- Mainnet value: 5 %! 100
          , sgSecurityParam :: Word64
sgSecurityParam = Word64
108 -- Mainnet value: 2160
          , sgEpochLength :: EpochSize
sgEpochLength = EpochSize
4320 -- Mainnet value: 432000
          , sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod = Word64
129600
          , sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions = Word64
62
          , sgSlotLength :: NominalDiffTimeMicro
sgSlotLength = NominalDiffTimeMicro
1
          , sgUpdateQuorum :: Word64
sgUpdateQuorum = Word64
5
          , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
45_000_000_000_000_000
          , sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams =
              forall era. EraPParams era => PParams era
emptyPParams
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155_381
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
65536
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
16384
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
500_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
18
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
150
                forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1000)
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Nonce
NeutralNonce
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
340_000_000
          , -- TODO: Add a top level definition and add private keys to ImpState:
            sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs = forall a. Monoid a => a
mempty
          , sgInitialFunds :: ListMap (Addr c) Coin
sgInitialFunds = forall a. Monoid a => a
mempty
          , sgStaking :: ShelleyGenesisStaking c
sgStaking = forall a. Monoid a => a
mempty
          }
    case forall c. Crypto c => ShelleyGenesis c -> Either [ValidationErr] ()
validateGenesis ShelleyGenesis c
gen of
      Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis c
gen
      Left [ValidationErr]
errs -> forall (m :: * -> *) a. MonadFail m => ConstructorName -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConstructorName
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ValidationErr -> Text
describeValidationErr [ValidationErr]
errs

  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s (EraCrypto (ShelleyEra c)), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState (ShelleyEra c))
initNewEpochState = do
    ShelleyGenesis c
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @(ShelleyEra c)
    let transContext :: FromByronTranslationContext c
transContext = forall c. ShelleyGenesis c -> FromByronTranslationContext c
toFromByronTranslationContext ShelleyGenesis c
shelleyGenesis
        startEpochNo :: EpochNo
startEpochNo = forall era. Era era => EpochNo
impEraStartEpochNo @(ShelleyEra c)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c.
(Crypto c, ADDRHASH c ~ Blake2b_224) =>
FromByronTranslationContext c
-> EpochNo -> UTxO -> NewEpochState (ShelleyEra c)
translateToShelleyLedgerStateFromUtxo FromByronTranslationContext c
transContext EpochNo
startEpochNo UTxO
Byron.empty

  impSatisfyNativeScript :: Set (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
-> TxBody (ShelleyEra c)
-> NativeScript (ShelleyEra c)
-> ImpTestM
     (ShelleyEra c)
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
           (KeyPair 'Witness (EraCrypto (ShelleyEra c)))))
impSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
providedVKeyHashes TxBody (ShelleyEra c)
_txBody NativeScript (ShelleyEra c)
script = do
    Map
  (KeyHash 'Witness (EraCrypto (ShelleyEra c))) (KeyPair 'Witness c)
keyPairs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era.
ImpTestState era
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
impKeyPairs
    let
      satisfyMOf :: Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf Int
m StrictSeq (NativeScript (ShelleyEra c))
Empty
        | Int
m forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise = forall a. Maybe a
Nothing
      satisfyMOf Int
m (NativeScript (ShelleyEra c)
x :<| StrictSeq (NativeScript (ShelleyEra c))
xs) =
        case NativeScript (ShelleyEra c)
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyScript NativeScript (ShelleyEra c)
x of
          Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
Nothing -> Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf Int
m StrictSeq (NativeScript (ShelleyEra c))
xs
          Just Map (KeyHash 'Witness c) (KeyPair 'Witness c)
kps -> do
            Map (KeyHash 'Witness c) (KeyPair 'Witness c)
kps' <- Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf (Int
m forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript (ShelleyEra c))
xs
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Witness c) (KeyPair 'Witness c)
kps forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'Witness c) (KeyPair 'Witness c)
kps'
      satisfyScript :: NativeScript (ShelleyEra c)
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyScript = \case
        RequireSignature KeyHash 'Witness (EraCrypto (ShelleyEra c))
keyHash
          | KeyHash 'Witness (EraCrypto (ShelleyEra c))
keyHash forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
providedVKeyHashes -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
          | Bool
otherwise -> do
              KeyPair 'Witness c
keyPair <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Witness (EraCrypto (ShelleyEra c))
keyHash Map
  (KeyHash 'Witness (EraCrypto (ShelleyEra c))) (KeyPair 'Witness c)
keyPairs
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton KeyHash 'Witness (EraCrypto (ShelleyEra c))
keyHash KeyPair 'Witness c
keyPair
        RequireAllOf StrictSeq (NativeScript (ShelleyEra c))
ss -> Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript (ShelleyEra c))
ss) StrictSeq (NativeScript (ShelleyEra c))
ss
        RequireAnyOf StrictSeq (NativeScript (ShelleyEra c))
ss -> Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf Int
1 StrictSeq (NativeScript (ShelleyEra c))
ss
        RequireMOf Int
m StrictSeq (NativeScript (ShelleyEra c))
ss -> Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyMOf Int
m StrictSeq (NativeScript (ShelleyEra c))
ss
        NativeScript (ShelleyEra c)
_ -> forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Impossible: All NativeScripts should have been accounted for"

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NativeScript (ShelleyEra c)
-> Maybe (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
satisfyScript NativeScript (ShelleyEra c)
script

  fixupTx :: HasCallStack =>
Tx (ShelleyEra c) -> ImpTestM (ShelleyEra c) (Tx (ShelleyEra c))
fixupTx = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx

-- | Figure out all the Byron Addresses that need witnesses as well as all of the
-- KeyHashes for Shelley Key witnesses that are required.
impWitsVKeyNeeded ::
  EraUTxO era =>
  TxBody era ->
  ImpTestM
    era
    ( Set.Set (BootstrapAddress (EraCrypto era)) -- Byron Based Addresses
    , Set.Set (KeyHash 'Witness (EraCrypto era)) -- Shelley Based KeyHashes
    )
impWitsVKeyNeeded :: forall era.
EraUTxO era =>
TxBody era
-> ImpTestM
     era
     (Set (BootstrapAddress (EraCrypto era)),
      Set (KeyHash 'Witness (EraCrypto era)))
impWitsVKeyNeeded TxBody era
txBody = do
  LedgerState era
ls <- 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)
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let toBootAddr :: TxIn (EraCrypto era) -> Maybe (BootstrapAddress (EraCrypto era))
toBootAddr TxIn (EraCrypto era)
txIn = do
        TxOut era
txOut <- forall era. TxIn (EraCrypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (EraCrypto era)
txIn UTxO era
utxo
        TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe (BootstrapAddress (EraCrypto era)))
bootAddrTxOutF
      bootAddrs :: Set (BootstrapAddress (EraCrypto era))
bootAddrs = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxIn (EraCrypto era) -> Maybe (BootstrapAddress (EraCrypto era))
toBootAddr forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era)))
spendableInputsTxBodyF)
      bootKeyHashes :: Set (KeyHash 'Witness (EraCrypto era))
bootKeyHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BootstrapAddress c -> KeyHash 'Payment c
bootstrapKeyHash) Set (BootstrapAddress (EraCrypto era))
bootAddrs
      allKeyHashes :: Set (KeyHash 'Witness (EraCrypto era))
allKeyHashes =
        forall era.
EraUTxO era =>
CertState era
-> UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
getWitsVKeyNeeded (LedgerState era
ls forall s a. s -> Getting a s a -> a
^. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL) (LedgerState era
ls forall s a. s -> Getting a s a -> a
^. 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) TxBody era
txBody
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set (BootstrapAddress (EraCrypto era))
bootAddrs, Set (KeyHash 'Witness (EraCrypto era))
allKeyHashes forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness (EraCrypto era))
bootKeyHashes)

data ImpTestEnv era = ImpTestEnv
  { forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup :: Tx era -> ImpTestM era (Tx era)
  , forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures :: !Bool
  -- ^ Expect failures in CBOR round trip serialization tests for predicate failures
  }

iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL :: forall era.
Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup (\ImpTestEnv era
x Tx era -> ImpTestM era (Tx era)
y -> ImpTestEnv era
x {iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = Tx era -> ImpTestM era (Tx era)
y})

iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL :: forall era. Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures (\ImpTestEnv era
x Bool
y -> ImpTestEnv era
x {iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
y})

instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
  writer :: forall a. (a, [SomeSTSEvent era]) -> ImpTestM era a
writer (a
x, [SomeSTSEvent era]
evs) = (forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> [SomeSTSEvent era]
evs)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
x
  listen :: forall a. ImpTestM era a -> ImpTestM era (a, [SomeSTSEvent era])
listen ImpTestM era a
act = do
    [SomeSTSEvent era]
oldEvs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL
    forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Monoid a => a
mempty
    a
res <- ImpTestM era a
act
    [SomeSTSEvent era]
newEvs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL
    forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [SomeSTSEvent era]
oldEvs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
res, [SomeSTSEvent era]
newEvs)
  pass :: forall a.
ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
-> ImpTestM era a
pass ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act = do
    ((a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f), [SomeSTSEvent era]
evs) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act
    forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f [SomeSTSEvent era]
evs)

runShelleyBase :: ShelleyBase a -> ImpTestM era a
runShelleyBase :: forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase ShelleyBase a
act = do
  Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ShelleyBase a
act Globals
globals

getRewardAccountAmount :: RewardAccount (EraCrypto era) -> ImpTestM era Coin
getRewardAccountAmount :: forall era. RewardAccount (EraCrypto era) -> ImpTestM era Coin
getRewardAccountAmount RewardAccount (EraCrypto era)
rewardAccount = do
  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) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (UMap (EraCrypto era))
epochStateUMapL
  let cred :: Credential 'Staking (EraCrypto era)
cred = forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAccount (EraCrypto era)
rewardAccount
  case forall k c v. k -> UView c k v -> Maybe v
UMap.lookup Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
umap) of
    Maybe RDPair
Nothing -> forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
ConstructorName -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ ConstructorName
"Expected a reward account: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show Credential 'Staking (EraCrypto era)
cred
    Just RDPair {CompactForm Coin
rdReward :: RDPair -> CompactForm Coin
rdReward :: CompactForm Coin
rdReward} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
rdReward

lookupImpRootTxOut :: ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut :: forall era. ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut = do
  ImpTestState {TxIn (EraCrypto era)
impRootTxIn :: TxIn (EraCrypto era)
impRootTxIn :: forall era. ImpTestState era -> TxIn (EraCrypto era)
impRootTxIn} <- forall s (m :: * -> *). MonadState s m => m s
get
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case forall era. TxIn (EraCrypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (EraCrypto era)
impRootTxIn UTxO era
utxo of
    Maybe (TxOut era)
Nothing -> forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Root txId no longer points to an existing unspent output"
    Just TxOut era
rootTxOut -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn (EraCrypto era)
impRootTxIn, TxOut era
rootTxOut)

impAddNativeScript ::
  forall era.
  EraScript era =>
  NativeScript era ->
  ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript :: forall era.
EraScript era =>
NativeScript era -> ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript NativeScript era
nativeScript = do
  let script :: Script era
script = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
nativeScript
      scriptHash :: ScriptHash (EraCrypto era)
scriptHash = forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
script
  forall era.
Lens'
  (ImpTestState era)
  (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash (EraCrypto era)
scriptHash NativeScript era
nativeScript
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash (EraCrypto era)
scriptHash

impNativeScriptsRequired ::
  EraUTxO era =>
  Tx era ->
  ImpTestM era (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsRequired :: forall era.
EraUTxO era =>
Tx era
-> ImpTestM
     era (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsRequired Tx era
tx = do
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  ImpTestState {Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts :: Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts :: forall era.
ImpTestState era
-> Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts} <- forall s (m :: * -> *). MonadState s m => m s
get
  let needed :: ScriptsNeeded era
needed = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
      hashesNeeded :: Set (ScriptHash (EraCrypto era))
hashesNeeded = forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded ScriptsNeeded era
needed
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set (ScriptHash (EraCrypto era))
hashesNeeded

-- | Modifies transaction by adding necessary scripts
addNativeScriptTxWits ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
addNativeScriptTxWits :: forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"addNativeScriptTxWits" forall a b. (a -> b) -> a -> b
$ do
  Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era
-> ImpTestM
     era (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsRequired Tx era
tx
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let ScriptsProvided Map (ScriptHash (EraCrypto era)) (Script era)
provided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
      scriptsToAdd :: Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsToAdd = Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ Map (ScriptHash (EraCrypto era)) (Script era)
provided
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
scriptTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsToAdd

-- | Adds @TxWits@ that will satisfy all of the required key witnesses
updateAddrTxWits ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
updateAddrTxWits :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"updateAddrTxWits" forall a b. (a -> b) -> a -> b
$ do
  let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      txBodyHash :: SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash = forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody
  (Set (BootstrapAddress (EraCrypto era))
bootAddrs, Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeeded) <- forall era.
EraUTxO era =>
TxBody era
-> ImpTestM
     era
     (Set (BootstrapAddress (EraCrypto era)),
      Set (KeyHash 'Witness (EraCrypto era)))
impWitsVKeyNeeded TxBody era
txBody
  -- Shelley Based Addr Witnesses
  let curAddrWitHashes :: Set (KeyHash 'Witness (EraCrypto era))
curAddrWitHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL
  [KeyPair 'Witness (EraCrypto era)]
extraKeyPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeeded forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness (EraCrypto era))
curAddrWitHashes)
  let extraAddrVKeyWits :: Set (WitVKey 'Witness (EraCrypto era))
extraAddrVKeyWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash [KeyPair 'Witness (EraCrypto era)]
extraKeyPairs
      addrWitHashes :: Set (KeyHash 'Witness (EraCrypto era))
addrWitHashes = Set (KeyHash 'Witness (EraCrypto era))
curAddrWitHashes forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash Set (WitVKey 'Witness (EraCrypto era))
extraAddrVKeyWits
  -- Shelley Based Native Script Witnesses
  Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era
-> ImpTestM
     era (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsRequired Tx era
tx
  [Maybe
   (Map
      (KeyHash 'Witness (EraCrypto era))
      (KeyPair 'Witness (EraCrypto era)))]
nativeScriptsKeyPairs <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness (EraCrypto era))
-> TxBody era
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto era))
addrWitHashes TxBody era
txBody) (forall k a. Map k a -> [a]
Map.elems Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired)
  let extraNativeScriptVKeyWits :: Set (WitVKey 'Witness (EraCrypto era))
extraNativeScriptVKeyWits =
        forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems (forall a. Monoid a => [a] -> a
mconcat (forall a. [Maybe a] -> [a]
catMaybes [Maybe
   (Map
      (KeyHash 'Witness (EraCrypto era))
      (KeyPair 'Witness (EraCrypto era)))]
nativeScriptsKeyPairs))
  -- Byron Based Witessed
  let curBootAddrWitHashes :: Set (KeyHash 'Witness (EraCrypto era))
curBootAddrWitHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall c. Crypto c => BootstrapWitness c -> KeyHash 'Witness c
bootstrapWitKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (BootstrapWitness (EraCrypto era)))
bootAddrTxWitsL
      bootAddrWitsNeeded :: [BootstrapAddress (EraCrypto era)]
bootAddrWitsNeeded =
        [ BootstrapAddress (EraCrypto era)
bootAddr
        | BootstrapAddress (EraCrypto era)
bootAddr <- forall a. Set a -> [a]
Set.toList Set (BootstrapAddress (EraCrypto era))
bootAddrs
        , Bool -> Bool
not (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole (forall c. Crypto c => BootstrapAddress c -> KeyHash 'Payment c
bootstrapKeyHash BootstrapAddress (EraCrypto era)
bootAddr) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness (EraCrypto era))
curBootAddrWitHashes)
        ]
  [BootstrapWitness (EraCrypto era)]
extraBootAddrWits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [BootstrapAddress (EraCrypto era)]
bootAddrWitsNeeded forall a b. (a -> b) -> a -> b
$ \bootAddr :: BootstrapAddress (EraCrypto era)
bootAddr@(BootstrapAddress Address
byronAddr) -> do
    ByronKeyPair VerificationKey
_ SigningKey
signingKey <- forall s c (m :: * -> *).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
BootstrapAddress c -> m ByronKeyPair
lookupByronKeyPair BootstrapAddress (EraCrypto era)
bootAddr
    let attrs :: Attributes AddrAttributes
attrs = Address -> Attributes AddrAttributes
Byron.addrAttributes Address
byronAddr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c.
(DSIGN c ~ Ed25519DSIGN, Crypto c) =>
Hash c EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness c
makeBootstrapWitness (forall c i. SafeHash c i -> Hash (HASH c) i
extractHash SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash) SigningKey
signingKey Attributes AddrAttributes
attrs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness (EraCrypto era))
extraAddrVKeyWits forall a. Semigroup a => a -> a -> a
<> Set (WitVKey 'Witness (EraCrypto era))
extraNativeScriptVKeyWits
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (BootstrapWitness (EraCrypto era)))
bootAddrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall a. Ord a => [a] -> Set a
Set.fromList [BootstrapWitness (EraCrypto era)]
extraBootAddrWits

-- | This fixup step ensures that there are enough funds in the transaction.
addRootTxIn ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
addRootTxIn :: forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"addRootTxIn" forall a b. (a -> b) -> a -> b
$ do
  TxIn (EraCrypto era)
rootTxIn <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      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) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert TxIn (EraCrypto era)
rootTxIn

impNativeScriptKeyPairs ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM
    era
    (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))
impNativeScriptKeyPairs :: forall era.
ShelleyEraImp era =>
Tx era
-> ImpTestM
     era
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
impNativeScriptKeyPairs Tx era
tx = do
  Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era
-> ImpTestM
     era (Map (ScriptHash (EraCrypto era)) (NativeScript era))
impNativeScriptsRequired Tx era
tx
  let nativeScripts :: [NativeScript era]
nativeScripts = forall k a. Map k a -> [a]
Map.elems Map (ScriptHash (EraCrypto era)) (NativeScript era)
scriptsRequired
      curAddrWits :: Set (KeyHash 'Witness (EraCrypto era))
curAddrWits = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL
  [Maybe
   (Map
      (KeyHash 'Witness (EraCrypto era))
      (KeyPair 'Witness (EraCrypto era)))]
keyPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness (EraCrypto era))
-> TxBody era
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto era))
curAddrWits forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL) [NativeScript era]
nativeScripts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe
   (Map
      (KeyHash 'Witness (EraCrypto era))
      (KeyPair 'Witness (EraCrypto era)))]
keyPairs

fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)
fixupTxOuts :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts Tx era
tx = 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
  let
    txOuts :: StrictSeq (TxOut era)
txOuts = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
  StrictSeq (TxOut era)
fixedUpTxOuts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM StrictSeq (TxOut era)
txOuts forall a b. (a -> b) -> a -> b
$ \TxOut era
txOut -> do
    if TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall a. Eq a => a -> a -> Bool
== forall t. Val t => t
zero
      then do
        let txOut' :: TxOut era
txOut' = forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
txOut
        forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle
"Fixed up the amount in the TxOut to " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (TxOut era
txOut' forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut'
      else do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx 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
.~ StrictSeq (TxOut era)
fixedUpTxOuts

fixupFees ::
  (ShelleyEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupFees :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees Tx era
txOriginal = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"fixupFees" forall a b. (a -> b) -> a -> b
$ do
  -- Fee will be overwritten later on, unless it wasn't set to zero to begin with:
  let tx :: Tx era
tx = Tx era
txOriginal 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) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t. Val t => t
zero
  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
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  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
  (KeyHash 'Payment (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
kpSpending) <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
  (KeyHash 'Staking (EraCrypto era)
_, KeyPair 'Staking (EraCrypto era)
kpStaking) <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
  Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
nativeScriptKeyPairs <- forall era.
ShelleyEraImp era =>
Tx era
-> ImpTestM
     era
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
impNativeScriptKeyPairs Tx era
tx
  let
    nativeScriptKeyWits :: Set (KeyHash 'Witness (EraCrypto era))
nativeScriptKeyWits = forall k a. Map k a -> Set k
Map.keysSet Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
nativeScriptKeyPairs
    consumedValue :: Value era
consumedValue = forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
    producedValue :: Value era
producedValue = forall era.
EraUTxO era =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
    ensureNonNegativeCoin :: a -> ImpM t a
ensureNonNegativeCoin a
v
      | forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
pointwise forall a. Ord a => a -> a -> Bool
(<=) forall t. Val t => t
zero a
v = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
      | Bool
otherwise = do
          forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Failed to validate coin: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr a
v
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall t. Val t => t
zero
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating changeBeforeFee"
  Coin
changeBeforeFee <- forall {a} {t}. (Val a, ToExpr a) => a -> ImpM t a
ensureNonNegativeCoin forall a b. (a -> b) -> a -> b
$ forall t. Val t => t -> Coin
coin Value era
consumedValue forall t. Val t => t -> t -> t
<-> forall t. Val t => t -> Coin
coin Value era
producedValue
  forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Coin
changeBeforeFee
  let
    changeBeforeFeeTxOut :: TxOut era
changeBeforeFeeTxOut =
      forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut
        (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (KeyPair 'Payment (EraCrypto era)
kpSpending, KeyPair 'Staking (EraCrypto era)
kpStaking))
        (forall t s. Inject t s => t -> s
inject Coin
changeBeforeFee)
    txNoWits :: Tx era
txNoWits = Tx era
tx 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 -> (a -> b) -> s -> t
%~ (forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeBeforeFeeTxOut)
    outsBeforeFee :: StrictSeq (TxOut era)
outsBeforeFee = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
    suppliedFee :: Coin
suppliedFee = Tx era
txOriginal forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
    fee :: Coin
fee
      | Coin
suppliedFee forall a. Eq a => a -> a -> Bool
== forall t. Val t => t
zero = forall era.
EraUTxO era =>
UTxO era
-> PParams era
-> Tx era
-> Set (KeyHash 'Witness (EraCrypto era))
-> Coin
calcMinFeeTxNativeScriptWits UTxO era
utxo PParams era
pp Tx era
txNoWits Set (KeyHash 'Witness (EraCrypto era))
nativeScriptKeyWits
      | Bool
otherwise = Coin
suppliedFee
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating change"
  Coin
change <- forall {a} {t}. (Val a, ToExpr a) => a -> ImpM t a
ensureNonNegativeCoin forall a b. (a -> b) -> a -> b
$ TxOut era
changeBeforeFeeTxOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall t. Val t => t -> t -> t
<-> Coin
fee
  forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Coin
change
  let
    changeTxOut :: TxOut era
changeTxOut = TxOut era
changeBeforeFeeTxOut forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
change
    -- If the remainder is sufficently big we add it to outputs, otherwise we add the
    -- extraneous coin to the fee and discard the remainder TxOut
    txWithFee :: Tx era
txWithFee
      | Coin
change forall a. Ord a => a -> a -> Bool
>= forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
changeTxOut =
          Tx era
txNoWits
            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
.~ (StrictSeq (TxOut era)
outsBeforeFee forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeTxOut)
            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) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
      | Bool
otherwise =
          Tx era
txNoWits
            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
.~ StrictSeq (TxOut era)
outsBeforeFee
            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) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
fee forall a. Semigroup a => a -> a -> a
<> Coin
change)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
txWithFee

-- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not.
fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era)
fixupAuxDataHash :: forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash Tx era
tx
  | StrictMaybe (AuxiliaryDataHash (EraCrypto era))
SNothing <- Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
auxDataHashTxBodyL
  , SJust TxAuxData era
auxData <- Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
tx 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) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
auxDataHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall c. SafeHash c EraIndependentTxAuxData -> AuxiliaryDataHash c
AuxiliaryDataHash (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxAuxData era
auxData)))
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

shelleyFixupTx ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
shelleyFixupTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx =
  forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (\Tx era
tx -> forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx era -> ImpTestM era ()
logFeeMismatch Tx era
tx forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Tx era
tx)

logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era ()
logFeeMismatch :: forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx era -> ImpTestM era ()
logFeeMismatch Tx era
tx = 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
  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
  let Coin Integer
feeUsed = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
      Coin Integer
feeMin = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
feeUsed forall a. Eq a => a -> a -> Bool
/= Integer
feeMin) forall a b. (a -> b) -> a -> b
$ do
    forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle
"Estimated fee " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeUsed forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" while required fee is " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeMin

submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era ()
submitTx_ :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx

submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era)
submitTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a, b) -> a
fst

trySubmitTx ::
  forall era.
  ( ShelleyEraImp era
  , HasCallStack
  ) =>
  Tx era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx = do
  Tx era
txFixed <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (a -> b) -> a -> b
$ Tx era
tx)
  forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Tx era
txFixed
  NewEpochState era
st <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES
  LedgerEnv era
lEnv <- forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
st
  ImpTestState {TxIn (EraCrypto era)
impRootTxIn :: TxIn (EraCrypto era)
impRootTxIn :: forall era. ImpTestState era -> TxIn (EraCrypto era)
impRootTxIn} <- forall s (m :: * -> *). MonadState s m => m s
get
  Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res <- forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @"LEDGER" LedgerEnv era
lEnv (NewEpochState era
st forall s a. s -> Getting a s a -> a
^. 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) Tx era
txFixed
  Bool
roundTripCheck <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures
  case Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res of
    Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures -> do
      -- Verify that produced predicate failures are ready for the node-to-client protocol
      if Bool
roundTripCheck
        then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures forall a b. (a -> b) -> a -> b
$ forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> IO ()
roundTripEraExpectation @era
        else
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation
              (forall era. Era era => Version
eraProtVerLow @era)
              (forall era. Era era => Version
eraProtVerHigh @era)
              NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
txFixed)
    Right (LedgerState era
st', [Event (EraRule "LEDGER" era)]
events) -> do
      let txId :: TxId (EraCrypto era)
txId = forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated forall a b. (a -> b) -> a -> b
$ Tx era
txFixed forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
          outsSize :: Int
outsSize = forall a. StrictSeq a -> Int
SSeq.length forall a b. (a -> b) -> a -> b
$ Tx era
txFixed forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
          rootIndex :: Int
rootIndex
            | Int
outsSize forall a. Ord a => a -> a -> Bool
> Int
0 = Int
outsSize forall a. Num a => a -> a -> a
- Int
1
            | Bool
otherwise = forall a. HasCallStack => ConstructorName -> a
error (ConstructorName
"Expected at least 1 output after submitting tx: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show TxId (EraCrypto era)
txId)
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"LEDGER") [Event (EraRule "LEDGER" era)]
events
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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 s t a b. ASetter s t a b -> b -> s -> t
.~ LedgerState era
st'
      UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
      -- This TxIn is in the utxo, and thus can be the new root, only if the transaction
      -- was phase2-valid.  Otherwise, no utxo with this id would have been created, and
      -- so we need to set the new root to what it was before the submission.
      let assumedNewRoot :: TxIn (EraCrypto era)
assumedNewRoot = forall c. TxId c -> TxIx -> TxIn c
TxIn TxId (EraCrypto era)
txId (HasCallStack => Integer -> TxIx
mkTxIxPartial (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rootIndex))
      let newRoot :: TxIn (EraCrypto era)
newRoot
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn (EraCrypto era)
assumedNewRoot Map (TxIn (EraCrypto era)) (TxOut era)
utxo = TxIn (EraCrypto era)
assumedNewRoot
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn (EraCrypto era)
impRootTxIn Map (TxIn (EraCrypto era)) (TxOut era)
utxo = TxIn (EraCrypto era)
impRootTxIn
            | Bool
otherwise = forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Root not found in UTxO"
      forall era. Lens' (ImpTestState era) (TxIn (EraCrypto era))
impRootTxInL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TxIn (EraCrypto era)
newRoot
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Tx era
txFixed

-- | Submit a transaction that is expected to be rejected with the given predicate failures.
-- The inputs and outputs are automatically balanced.
submitFailingTx ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx = forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Submit a transaction that is expected to be rejected, and compute
-- the expected predicate failures from the fixed-up tx using the supplied action.
-- The inputs and outputs are automatically balanced.
submitFailingTxM ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) ->
  ImpTestM era ()
submitFailingTxM :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures = do
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
fixedUpTx) <- forall b a (m :: * -> *).
(HasCallStack, ToExpr b, NFData a, MonadIO m) =>
Either a b -> m a
expectLeftDeepExpr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures <- Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures Tx era
fixedUpTx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures

tryRunImpRule ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRule :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule = forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' @rule AssertionPolicy
AssertionsAll

tryRunImpRuleNoAssertions ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRuleNoAssertions :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRuleNoAssertions = forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' @rule AssertionPolicy
AssertionsOff

tryRunImpRule' ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  AssertionPolicy ->
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRule' :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' AssertionPolicy
assertionPolicy Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let trc :: TRC (EraRule rule era)
trc = forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule rule era)
stsEnv, State (EraRule rule era)
stsState, Signal (EraRule rule era)
stsSignal)
  let
    stsOpts :: ApplySTSOpts 'EventPolicyReturn
stsOpts =
      ApplySTSOpts
        { asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
        , asoEvents :: SingEP 'EventPolicyReturn
asoEvents = SingEP 'EventPolicyReturn
EPReturn
        , asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
assertionPolicy
        }
  forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase (forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
        (NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule rule era) ApplySTSOpts 'EventPolicyReturn
stsOpts TRC (EraRule rule era)
trc)

runImpRule ::
  forall rule era.
  ( HasCallStack
  , KnownSymbol rule
  , STS (EraRule rule era)
  , BaseM (EraRule rule era) ~ ShelleyBase
  , NFData (State (EraRule rule era))
  , NFData (Event (EraRule rule era))
  , ToExpr (Event (EraRule rule era))
  , Eq (Event (EraRule rule era))
  , Typeable (Event (EraRule rule era))
  ) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM era (State (EraRule rule era))
runImpRule :: forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let ruleName :: ConstructorName
ruleName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> ConstructorName
symbolVal (forall {k} (t :: k). Proxy t
Proxy @rule)
  (State (EraRule rule era)
res, [Event (EraRule rule era)]
ev) <-
    forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @rule Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left NonEmpty (PredicateFailure (EraRule rule era))
fs ->
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
ConstructorName -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
          [ConstructorName] -> ConstructorName
unlines forall a b. (a -> b) -> a -> b
$
            (ConstructorName
"Failed to run " forall a. Semigroup a => a -> a -> a
<> ConstructorName
ruleName forall a. Semigroup a => a -> a -> a
<> ConstructorName
":") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> ConstructorName
show (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PredicateFailure (EraRule rule era))
fs)
      Right (State (EraRule rule era), [Event (EraRule rule era)])
res -> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (State (EraRule rule era), [Event (EraRule rule era)])
res
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @rule) [Event (EraRule rule era)]
ev
  forall (f :: * -> *) a. Applicative f => a -> f a
pure State (EraRule rule era)
res

-- | Runs the TICK rule once
passTick ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era ()
passTick :: forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick = do
  SlotNo
impLastTick <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  NewEpochState era
curNES <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a. a -> a
id
  NewEpochState era
nes <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"TICK" () NewEpochState era
curNES SlotNo
impLastTick
  forall era. Lens' (ImpTestState era) SlotNo
impLastTickL forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= SlotNo
1
  forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= NewEpochState era
nes

-- | Runs the TICK rule until the next epoch is reached
passEpoch ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  ImpTestM era ()
passEpoch :: forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch = do
  let
    tickUntilNewEpoch :: EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo = do
      forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick @era
      EpochNo
newEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EpochNo
newEpochNo forall a. Ord a => a -> a -> Bool
> EpochNo
curEpochNo) forall a b. (a -> b) -> a -> b
$ EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo
  NewEpochState era
preNES <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES
  let startEpoch :: EpochNo
startEpoch = NewEpochState era
preNES forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Entering " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (forall a. Enum a => a -> a
succ EpochNo
startEpoch)
  EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
startEpoch
  forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(EraTxOut era, EraGov era, HasCallStack) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
preNES

epochBoundaryCheck ::
  (EraTxOut era, EraGov era, HasCallStack) =>
  NewEpochState era ->
  NewEpochState era ->
  ImpTestM era ()
epochBoundaryCheck :: forall era.
(EraTxOut era, EraGov era, HasCallStack) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
preNES NewEpochState era
postNES = do
  forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking ADA preservation at the epoch boundary" forall a b. (a -> b) -> a -> b
$ do
    let preSum :: Coin
preSum = forall {era}.
(EraTxOut era, EraGov era) =>
NewEpochState era -> Coin
tot NewEpochState era
preNES
        postSum :: Coin
postSum = forall {era}.
(EraTxOut era, EraGov era) =>
NewEpochState era -> Coin
tot NewEpochState era
postNES
    forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Coin
preSum Coin
postSum
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Coin
preSum forall a. Eq a => a -> a -> Bool
== Coin
postSum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$
      ConstructorName
"Total ADA in the epoch state is not preserved\n\tpost - pre = "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show (Coin
postSum forall t. Val t => t -> t -> t
<-> Coin
preSum)
  where
    tot :: NewEpochState era -> Coin
tot NewEpochState era
nes =
      forall t. Val t => t -> t -> t
(<+>)
        (AdaPots -> Coin
sumAdaPots (forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL)))
        (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. 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) Coin
utxosDonationL)

-- | Runs the TICK rule until the `n` epochs are passed
passNEpochs ::
  forall era.
  ShelleyEraImp era =>
  Natural ->
  ImpTestM era ()
passNEpochs :: forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
n =
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

-- | Runs the TICK rule until the `n` epochs are passed, running the `checks`
-- each time.
passNEpochsChecking ::
  forall era.
  ShelleyEraImp era =>
  Natural ->
  ImpTestM era () ->
  ImpTestM era ()
passNEpochsChecking :: forall era.
ShelleyEraImp era =>
Natural -> ImpTestM era () -> ImpTestM era ()
passNEpochsChecking Natural
n ImpTestM era ()
checks =
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) forall a b. (a -> b) -> a -> b
$ forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ImpTestM era ()
checks

-- | Adds a ToExpr to the log, which is only shown if the test fails
logToExpr :: (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr :: forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr = forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc AnsiStyle
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr

-- | Adds the result of an action to the log, which is only shown if the test fails
impLogToExpr :: (HasCallStack, ToExpr a) => ImpTestM era a -> ImpTestM era a
impLogToExpr :: forall a era.
(HasCallStack, ToExpr a) =>
ImpTestM era a -> ImpTestM era a
impLogToExpr ImpTestM era a
action = do
  a
e <- ImpTestM era a
action
  forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc AnsiStyle
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ a
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
e

-- | Creates a fresh @SafeHash@
freshSafeHash :: Era era => ImpTestM era (SafeHash (EraCrypto era) a)
freshSafeHash :: forall era a. Era era => ImpTestM era (SafeHash (EraCrypto era) a)
freshSafeHash = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary

freshKeyHashVRF ::
  Era era =>
  ImpTestM era (VRFVerKeyHash (r :: KeyRoleVRF) (EraCrypto era))
freshKeyHashVRF :: forall era (r :: KeyRoleVRF).
Era era =>
ImpTestM era (VRFVerKeyHash r (EraCrypto era))
freshKeyHashVRF = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary

-- | Adds a key pair to the keyhash lookup map
addKeyPair ::
  (HasKeyPairs s c, MonadState s m) =>
  KeyPair r c ->
  m (KeyHash r c)
addKeyPair :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m) =>
KeyPair r c -> m (KeyHash r c)
addKeyPair keyPair :: KeyPair r c
keyPair@(KeyPair VKey r c
vk SignKeyDSIGN (DSIGN c)
_) = do
  let keyHash :: KeyHash r c
keyHash = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey VKey r c
vk
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t c.
HasKeyPairs t c =>
Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
keyPairsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash r c
keyHash) (coerce :: forall a b. Coercible a b => a -> b
coerce KeyPair r c
keyPair)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash r c
keyHash

-- | Looks up the `KeyPair` corresponding to the `KeyHash`. The `KeyHash` must be
-- created with `freshKeyHash` for this to work.
lookupKeyPair ::
  (HasCallStack, HasKeyPairs s c, MonadState s m) =>
  KeyHash r c ->
  m (KeyPair r c)
lookupKeyPair :: forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair KeyHash r c
keyHash = do
  Map (KeyHash 'Witness c) (KeyPair 'Witness c)
keyPairs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall t c.
HasKeyPairs t c =>
Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
keyPairsL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash r c
keyHash) Map (KeyHash 'Witness c) (KeyPair 'Witness c)
keyPairs of
    Just KeyPair 'Witness c
keyPair -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce KeyPair 'Witness c
keyPair
    Maybe (KeyPair 'Witness c)
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show KeyHash r c
keyHash
          forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `KeyPair` in the
-- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for
-- generation or `lookupKeyPair` to look up the `KeyPair` corresponding to the `KeyHash`
freshKeyHash ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r c)
freshKeyHash :: forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair

-- | Generate a random `KeyPair` and add it to the known keys in the Imp state
freshKeyPair ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r c, KeyPair r c)
freshKeyPair :: forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair = do
  KeyPair r c
keyPair <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  KeyHash r c
keyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m) =>
KeyPair r c -> m (KeyHash r c)
addKeyPair KeyPair r c
keyPair
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash r c
keyHash, KeyPair r c
keyPair)

-- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair`
-- to the known keys in the Imp state.
freshKeyAddr_ ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) => m (Addr c)
freshKeyAddr_ :: forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (Addr c)
freshKeyAddr_ = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, Addr c)
freshKeyAddr

-- | Generate a random `Addr` that uses a `KeyHash`, add the corresponding `KeyPair`
-- to the known keys in the Imp state, and return the `KeyHash` as well as the `Addr`.
freshKeyAddr ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r c, Addr c)
freshKeyAddr :: forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, Addr c)
freshKeyAddr = do
  KeyHash 'Payment c
keyHash <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash 'Payment c
keyHash, forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Payment c
keyHash) forall c. StakeReference c
StakeRefNull)

-- | Looks up the keypair corresponding to the `BootstrapAddress`. The `BootstrapAddress`
-- must be created with `freshBootstrapAddess` for this to work.
lookupByronKeyPair ::
  (HasCallStack, HasKeyPairs s c, MonadState s m) =>
  BootstrapAddress c ->
  m ByronKeyPair
lookupByronKeyPair :: forall s c (m :: * -> *).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
BootstrapAddress c -> m ByronKeyPair
lookupByronKeyPair BootstrapAddress c
bootAddr = do
  Map (BootstrapAddress c) ByronKeyPair
keyPairs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall t c.
HasKeyPairs t c =>
Lens' t (Map (BootstrapAddress c) ByronKeyPair)
keyPairsByronL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BootstrapAddress c
bootAddr Map (BootstrapAddress c) ByronKeyPair
keyPairs of
    Just ByronKeyPair
keyPair -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByronKeyPair
keyPair
    Maybe ByronKeyPair
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show BootstrapAddress c
bootAddr
          forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshByronKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `ByronKeyPair` in the
-- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for
-- generation or `lookupByronKeyPair` to look up the `ByronKeyPair` corresponding to the `KeyHash`
freshByronKeyHash ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r c)
freshByronKeyHash :: forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshByronKeyHash = forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BootstrapAddress c -> KeyHash 'Payment c
bootstrapKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (BootstrapAddress c)
freshBootstapAddress

freshBootstapAddress ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
  m (BootstrapAddress c)
freshBootstapAddress :: forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (BootstrapAddress c)
freshBootstapAddress = do
  keyPair :: ByronKeyPair
keyPair@(ByronKeyPair VerificationKey
verificationKey SigningKey
_) <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Bool
hasPayload <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Maybe HDAddressPayload
payload <-
    if Bool
hasPayload
      then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HDAddressPayload
Byron.HDAddressPayload forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteString
uniformByteStringM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Int
0, Int
63))
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  let asd :: AddrSpendingData
asd = VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
verificationKey
      attrs :: AddrAttributes
attrs = Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes Maybe HDAddressPayload
payload (Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
0)
      bootAddr :: BootstrapAddress c
bootAddr = forall c. Address -> BootstrapAddress c
BootstrapAddress forall a b. (a -> b) -> a -> b
$ AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress AddrSpendingData
asd AddrAttributes
attrs
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t c.
HasKeyPairs t c =>
Lens' t (Map (BootstrapAddress c) ByronKeyPair)
keyPairsByronL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BootstrapAddress c
bootAddr ByronKeyPair
keyPair
  forall (f :: * -> *) a. Applicative f => a -> f a
pure BootstrapAddress c
bootAddr

sendCoinTo ::
  (ShelleyEraImp era, HasCallStack) =>
  Addr (EraCrypto era) ->
  Coin ->
  ImpTestM era (TxIn (EraCrypto era))
sendCoinTo :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
addr = forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era)
-> Value era -> ImpTestM era (TxIn (EraCrypto era))
sendValueTo Addr (EraCrypto era)
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject

sendValueTo ::
  (ShelleyEraImp era, HasCallStack) =>
  Addr (EraCrypto era) ->
  Value era ->
  ImpTestM era (TxIn (EraCrypto era))
sendValueTo :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era)
-> Value era -> ImpTestM era (TxIn (EraCrypto era))
sendValueTo Addr (EraCrypto era)
addr Value era
amount = do
  Tx era
tx <-
    forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn
      (ConstructorName
"Giving " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Value era
amount forall a. Semigroup a => a -> a -> a
<> ConstructorName
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Addr (EraCrypto era)
addr)
      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 Value era
amount)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
tx

-- | Modify the current new epoch state with a function
modifyNES :: (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES :: forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES = (forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%=)

-- | Get a value from the current new epoch state using the lens
getsNES :: SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES :: forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES SimpleGetter (NewEpochState era) a
l = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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
. SimpleGetter (NewEpochState era) a
l

getUTxO :: ImpTestM era (UTxO era)
getUTxO :: forall era. ImpTestM era (UTxO era)
getUTxO = 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

getProtVer :: EraGov era => ImpTestM era ProtVer
getProtVer :: forall era. EraGov era => ImpTestM era ProtVer
getProtVer = 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) ProtVer
ppProtocolVersionL

submitTxAnn ::
  (HasCallStack, ShelleyEraImp era) =>
  String ->
  Tx era ->
  ImpTestM era (Tx era)
submitTxAnn :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn ConstructorName
msg Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
msg (forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr)

submitTxAnn_ ::
  (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era ()
submitTxAnn_ :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
msg = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn ConstructorName
msg

getRewardAccountFor ::
  Credential 'Staking (EraCrypto era) ->
  ImpTestM era (RewardAccount (EraCrypto era))
getRewardAccountFor :: forall era.
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
getRewardAccountFor Credential 'Staking (EraCrypto era)
stakingC = do
  Network
networkId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall era. Lens' (ImpTestState era) Globals
impGlobalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
networkId Credential 'Staking (EraCrypto era)
stakingC

registerStakeCredential ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Credential 'Staking (EraCrypto era) ->
  ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential Credential 'Staking (EraCrypto era)
cred = do
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ (ConstructorName
"Register Reward Account: " forall a. Semigroup a => a -> a -> a
<> Text -> ConstructorName
T.unpack (forall (kr :: KeyRole) c. Credential kr c -> Text
credToText Credential 'Staking (EraCrypto era)
cred)) 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.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert @era Credential 'Staking (EraCrypto era)
cred]
  Network
networkId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall era. Lens' (ImpTestState era) Globals
impGlobalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
networkId Credential 'Staking (EraCrypto era)
cred

delegateStake ::
  ShelleyEraImp era =>
  Credential 'Staking (EraCrypto era) ->
  KeyHash 'StakePool (EraCrypto era) ->
  ImpTestM era ()
delegateStake :: forall era.
ShelleyEraImp era =>
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
delegateStake Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKH = do
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ (ConstructorName
"Delegate Staking Credential: " forall a. Semigroup a => a -> a -> a
<> Text -> ConstructorName
T.unpack (forall (kr :: KeyRole) c. Credential kr c -> Text
credToText Credential 'Staking (EraCrypto era)
cred)) 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.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKH]

registerRewardAccount ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount = do
  KeyHash 'Staking (EraCrypto era)
khDelegator <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
khDelegator)

tryLookupReward :: Credential 'Staking (EraCrypto era) -> ImpTestM era (Maybe Coin)
tryLookupReward :: forall era.
Credential 'Staking (EraCrypto era) -> ImpTestM era (Maybe Coin)
tryLookupReward Credential 'Staking (EraCrypto era)
stakingCredential = do
  UMap (EraCrypto era)
umap <- 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) (UMap (EraCrypto era))
epochStateUMapL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
rdReward forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k c v. k -> UView c k v -> Maybe v
UMap.lookup Credential 'Staking (EraCrypto era)
stakingCredential (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
umap)

lookupReward :: HasCallStack => Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward :: forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
stakingCredential = do
  Maybe Coin
mbyRwd <- forall era.
Credential 'Staking (EraCrypto era) -> ImpTestM era (Maybe Coin)
tryLookupReward Credential 'Staking (EraCrypto era)
stakingCredential
  case Maybe Coin
mbyRwd of
    Just Coin
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
c
    Maybe Coin
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Staking Credential is not found in the state: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Credential 'Staking (EraCrypto era)
stakingCredential
          forall a. Semigroup a => a -> a -> a
<> ConstructorName
"\nMake sure you have the reward account registered with `registerRewardAccount` "
          forall a. Semigroup a => a -> a -> a
<> ConstructorName
"or by some other means."

poolParams ::
  ShelleyEraImp era =>
  KeyHash 'StakePool (EraCrypto era) ->
  RewardAccount (EraCrypto era) ->
  ImpTestM era (PoolParams (EraCrypto era))
poolParams :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era)
-> ImpTestM era (PoolParams (EraCrypto era))
poolParams KeyHash 'StakePool (EraCrypto era)
khPool RewardAccount (EraCrypto era)
rewardAccount = do
  VRFVerKeyHash 'StakePoolVRF (EraCrypto era)
vrfHash <- forall era (r :: KeyRoleVRF).
Era era =>
ImpTestM era (VRFVerKeyHash r (EraCrypto era))
freshKeyHashVRF
  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 minCost :: Coin
minCost = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL
  Coin
poolCostExtra <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
100_000_000)
  Coin
pledge <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
100_000_000)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    PoolParams
      { ppVrf :: VRFVerKeyHash 'StakePoolVRF (EraCrypto era)
ppVrf = VRFVerKeyHash 'StakePoolVRF (EraCrypto era)
vrfHash
      , ppRewardAccount :: RewardAccount (EraCrypto era)
ppRewardAccount = RewardAccount (EraCrypto era)
rewardAccount
      , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. Monoid a => a
mempty
      , ppPledge :: Coin
ppPledge = Coin
pledge
      , ppOwners :: Set (KeyHash 'Staking (EraCrypto era))
ppOwners = forall a. Monoid a => a
mempty
      , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata = forall a. StrictMaybe a
SNothing
      , ppMargin :: UnitInterval
ppMargin = forall a. Default a => a
def
      , ppId :: KeyHash 'StakePool (EraCrypto era)
ppId = KeyHash 'StakePool (EraCrypto era)
khPool
      , ppCost :: Coin
ppCost = Coin
minCost forall a. Semigroup a => a -> a -> a
<> Coin
poolCostExtra
      }

registerPool ::
  ShelleyEraImp era =>
  KeyHash 'StakePool (EraCrypto era) ->
  ImpTestM era ()
registerPool :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
khPool = forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era) -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool (EraCrypto era)
khPool

registerPoolWithRewardAccount ::
  ShelleyEraImp era =>
  KeyHash 'StakePool (EraCrypto era) ->
  RewardAccount (EraCrypto era) ->
  ImpTestM era ()
registerPoolWithRewardAccount :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era) -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool (EraCrypto era)
khPool RewardAccount (EraCrypto era)
rewardAccount = do
  PoolParams (EraCrypto era)
pps <- forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era)
-> ImpTestM era (PoolParams (EraCrypto era))
poolParams KeyHash 'StakePool (EraCrypto era)
khPool RewardAccount (EraCrypto era)
rewardAccount
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
"Registering a new 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.singleton (forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
RegPoolTxCert PoolParams (EraCrypto era)
pps)

registerAndRetirePoolToMakeReward ::
  ShelleyEraImp era =>
  Credential 'Staking (EraCrypto era) ->
  ImpTestM era ()
registerAndRetirePoolToMakeReward :: forall era.
ShelleyEraImp era =>
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
registerAndRetirePoolToMakeReward Credential 'Staking (EraCrypto era)
stakingCred = do
  KeyHash 'StakePool (EraCrypto era)
poolId <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era) -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool (EraCrypto era)
poolId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
getRewardAccountFor Credential 'Staking (EraCrypto era)
stakingCred
  forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  let poolLifetime :: Word32
poolLifetime = Word32
2
      poolExpiry :: EpochNo
poolExpiry = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
poolLifetime
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
"Retiring the temporary 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.singleton (forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
poolExpiry)
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
poolLifetime

withCborRoundTripFailures :: ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures :: forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall era. Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False

-- | Compose given function with the configured fixup
withCustomFixup ::
  ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withCustomFixup :: forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall era.
Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f

-- | Replace all fixup with the given function
withFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (forall a b. a -> b -> a
const Tx era -> ImpTestM era (Tx era)
f)

-- | Performs the action without running the fix-up function on any transactions
withNoFixup :: ImpTestM era a -> ImpTestM era a
withNoFixup :: forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup = forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Apply given fixup function before the configured fixup
withPreFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPreFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPreFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era)
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>)

-- | Apply given fixup function after the configured fixup
withPostFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPostFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpTestM era (Tx era)
f)

expectUTxOContent ::
  (HasCallStack, ToExpr (TxOut era)) =>
  UTxO era -> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent :: forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a b. (a -> b) -> a -> b
$ \(TxIn (EraCrypto era)
txIn, Maybe (TxOut era) -> Bool
test) -> do
  let result :: Maybe (TxOut era)
result = TxIn (EraCrypto era)
txIn forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO UTxO era
utxo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TxOut era) -> Bool
test Maybe (TxOut era)
result) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$
      ConstructorName
"UTxO content failed predicate:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> ConstructorName
ansiExprString TxIn (EraCrypto era)
txIn forall a. Semigroup a => a -> a -> a
<> ConstructorName
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> ConstructorName
ansiExprString Maybe (TxOut era)
result

expectRegisteredRewardAddress :: RewardAccount (EraCrypto era) -> ImpTestM era ()
expectRegisteredRewardAddress :: forall era. RewardAccount (EraCrypto era) -> ImpTestM era ()
expectRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking (EraCrypto era)
cred) = do
  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) (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) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
  forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> Map (Credential 'Staking c) RDPair
rdPairMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True

expectNotRegisteredRewardAddress :: RewardAccount (EraCrypto era) -> ImpTestM era ()
expectNotRegisteredRewardAddress :: forall era. RewardAccount (EraCrypto era) -> ImpTestM era ()
expectNotRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking (EraCrypto era)
cred) = do
  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) (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) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
  forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> Map (Credential 'Staking c) RDPair
rdPairMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
False

expectTreasury :: HasCallStack => Coin -> ImpTestM era ()
expectTreasury :: forall era. HasCallStack => Coin -> ImpTestM era ()
expectTreasury Coin
c =
  forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking treasury amount" forall a b. (a -> b) -> a -> b
$ do
    Coin
treasuryAmt <- 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
c forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
treasuryAmt

-- Ensure no fees reach the treasury since that complicates withdrawal checks
disableTreasuryExpansion :: ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion :: forall era. ShelleyEraImp era => ImpM (LedgerSpec era) ()
disableTreasuryExpansion = forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
0 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)

impGetNativeScript :: ScriptHash (EraCrypto era) -> ImpTestM era (Maybe (NativeScript era))
impGetNativeScript :: forall era.
ScriptHash (EraCrypto era)
-> ImpTestM era (Maybe (NativeScript era))
impGetNativeScript ScriptHash (EraCrypto era)
sh = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash (EraCrypto era)
sh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era.
ImpTestState era
-> Map (ScriptHash (EraCrypto era)) (NativeScript era)
impNativeScripts

impLookupUTxO :: ShelleyEraImp era => TxIn (EraCrypto era) -> ImpTestM era (TxOut era)
impLookupUTxO :: forall era.
ShelleyEraImp era =>
TxIn (EraCrypto era) -> ImpTestM era (TxOut era)
impLookupUTxO TxIn (EraCrypto era)
txIn = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Looking up TxOut" forall a b. (a -> b) -> a -> b
$ do
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case forall era. TxIn (EraCrypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (EraCrypto era)
txIn UTxO era
utxo of
    Just TxOut era
txOut -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut
    Maybe (TxOut era)
Nothing -> forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$ ConstructorName
"Failed to get TxOut for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show TxIn (EraCrypto era)
txIn

produceScript ::
  (ShelleyEraImp era, HasCallStack) =>
  ScriptHash (EraCrypto era) ->
  ImpTestM era (TxIn (EraCrypto era))
produceScript :: forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
scriptHash = do
  let addr :: Addr (EraCrypto era)
addr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) forall c. StakeReference c
StakeRefNull
  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 (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 a. Monoid a => a
mempty)
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ ConstructorName
"Produced script: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show ScriptHash (EraCrypto era)
scriptHash
  forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx

advanceToPointOfNoReturn :: ImpTestM era ()
advanceToPointOfNoReturn :: forall era. ImpTestM era ()
advanceToPointOfNoReturn = do
  SlotNo
impLastTick <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  (EpochNo
_, SlotNo
slotOfNoReturn, EpochNo
_) <- forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase forall a b. (a -> b) -> a -> b
$ HasCallStack => SlotNo -> ShelleyBase (EpochNo, SlotNo, EpochNo)
getTheSlotOfNoReturn SlotNo
impLastTick
  forall era. Lens' (ImpTestState era) SlotNo
impLastTickL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SlotNo
slotOfNoReturn