{-# 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,
SomeSTSEvent (..),
runImpTestM,
runImpTestM_,
evalImpTestM,
execImpTestM,
runImpTestGenM,
runImpTestGenM_,
evalImpTestGenM,
execImpTestGenM,
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,
delegateStake,
registerRewardAccount,
registerStakeCredential,
getRewardAccountFor,
lookupReward,
poolParams,
registerPool,
registerPoolWithRewardAccount,
registerAndRetirePoolToMakeReward,
getRewardAccountAmount,
withImpState,
withImpStateModified,
shelleyFixupTx,
lookupImpRootTxOut,
sendValueTo,
sendCoinTo,
expectRegisteredRewardAddress,
expectNotRegisteredRewardAddress,
expectTreasury,
updateAddrTxWits,
addNativeScriptTxWits,
addRootTxIn,
fixupTxOuts,
fixupFees,
fixupAuxDataHash,
impGetNativeScript,
impLookupUTxO,
defaultInitNewEpochState,
defaultInitImpTestState,
impEraStartEpochNo,
impSetSeed,
Doc,
AnsiStyle,
logDoc,
logString,
logToExpr,
logStakeDistr,
logFeeMismatch,
withCustomFixup,
withFixup,
withNoFixup,
withPostFixup,
withPreFixup,
withCborRoundTripFailures,
impNESL,
impGlobalsL,
impLastTickG,
impKeyPairsG,
impNativeScriptsG,
produceScript,
advanceToPointOfNoReturn,
) 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 (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 (..),
KeyHash,
KeyRole (..),
VerKeyVRF,
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 (..),
fromNominalDiffTimeMicro,
mkShelleyGlobals,
)
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,
)
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 (..), StateT, 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.Class (Default (..))
import Data.Foldable (toList)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.IORef
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, 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.Stack (CallStack, SrcLoc (..), getCallStack)
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,
Pretty (..),
annotate,
hcat,
indent,
line,
vsep,
)
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color)
import System.Random
import qualified System.Random as Random
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
import Test.Cardano.Ledger.Binary.TreeDiff (srcLocToLocation)
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.HUnit.Lang (FailureReason (..), HUnitFailure (..))
import Test.Hspec.Core.Spec (
Example (..),
Params,
Result (..),
paramsQuickCheckArgs,
)
import qualified Test.Hspec.Core.Spec as H
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen)
import Type.Reflection (Typeable, typeOf)
import UnliftIO (MonadUnliftIO (..))
import UnliftIO.Exception (
Exception (..),
SomeException (..),
catchAny,
catchAnyDeep,
evaluateDeep,
throwIO,
)
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) = String -> [Expr] -> Expr
App String
"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 -> Doc AnsiStyle
impLog :: !(Doc AnsiStyle)
, forall era. ImpTestState era -> QCGen
impGen :: !QCGen
, forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents :: [SomeSTSEvent era]
}
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)
, forall c. ImpPrepState c -> QCGen
impPrepGen :: !QCGen
}
instance HasSubState (ImpPrepState era) where
type SubState (ImpPrepState era) = StateGen QCGen
getSubState :: ImpPrepState era -> SubState (ImpPrepState era)
getSubState = forall s. s -> StateGen s
StateGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ImpPrepState c -> QCGen
impPrepGen
setSubState :: ImpPrepState era -> SubState (ImpPrepState era) -> ImpPrepState era
setSubState ImpPrepState era
s (StateGen QCGen
g) = ImpPrepState era
s {impPrepGen :: QCGen
impPrepGen = QCGen
g}
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})
instance Monad m => HasStatefulGen (StateGenM (ImpPrepState era)) (StateT (ImpPrepState era) m) where
askStatefulGen :: StateT (ImpPrepState era) m (StateGenM (ImpPrepState era))
askStatefulGen = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall s. StateGenM s
StateGenM
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})
impLogL :: Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL :: forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Doc AnsiStyle
impLog (\ImpTestState era
x Doc AnsiStyle
y -> ImpTestState era
x {impLog :: Doc AnsiStyle
impLog = Doc AnsiStyle
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)
,
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
,
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)
,
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))
,
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 (HASH (EraCrypto era)) EraIndependentTxBody)
, ADDRHASH (EraCrypto era) ~ Blake2b_224
) =>
ShelleyEraImp era
where
initGenesis ::
(HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen (StateGenM s) 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 (StateGenM s) m) =>
m (NewEpochState era)
default initNewEpochState ::
( HasKeyPairs s (EraCrypto era)
, MonadState s m
, HasStatefulGen (StateGenM s) 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 s (m :: * -> *).
(MonadState s m, HasKeyPairs s (EraCrypto era),
HasStatefulGen (StateGenM s) 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
, HasSubState s
, SubState s ~ StateGen QCGen
, HasStatefulGen (StateGenM s) m
) =>
m (ImpTestState era)
initImpTestState = forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (NewEpochState era)
initNewEpochState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era s (m :: * -> *).
(EraGov era, EraTxOut era, DSIGN (EraCrypto era) ~ Ed25519DSIGN,
ADDRHASH (EraCrypto era) ~ Blake2b_224,
HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m, HasSubState s,
SubState s ~ StateGen QCGen) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState
impSatisfyNativeScript ::
Set.Set (KeyHash 'Witness (EraCrypto era)) ->
NativeScript era ->
ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
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 s m.
( MonadState s m
, HasKeyPairs s (EraCrypto era)
, HasStatefulGen (StateGenM s) 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 s (m :: * -> *).
(MonadState s m, HasKeyPairs s (EraCrypto era),
HasStatefulGen (StateGenM s) 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 :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (Genesis era)
initGenesis @era
NewEpochState (PreviousEra era)
nes <- forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (NewEpochState era)
initNewEpochState @(PreviousEra era)
let majProtVer :: Version
majProtVer = forall era. Era era => Version
eraProtVerLow @era
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
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 m.
( EraGov era
, EraTxOut era
, DSIGN (EraCrypto era) ~ Ed25519DSIGN
, ADDRHASH (EraCrypto era) ~ Blake2b_224
, HasKeyPairs s (EraCrypto era)
, MonadState s m
, HasStatefulGen (StateGenM s) m
, HasSubState s
, SubState s ~ StateGen QCGen
) =>
NewEpochState era ->
m (ImpTestState era)
defaultInitImpTestState :: forall era s (m :: * -> *).
(EraGov era, EraTxOut era, DSIGN (EraCrypto era) ~ Ed25519DSIGN,
ADDRHASH (EraCrypto era) ~ Blake2b_224,
HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m, HasSubState s,
SubState s ~ StateGen QCGen) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState NewEpochState era
nes = do
ShelleyGenesis (EraCrypto era)
shelleyGenesis <- forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (Genesis era)
initGenesis @(ShelleyEra (EraCrypto era))
KeyHash 'Payment (EraCrypto era)
rootKeyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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 StateGen QCGen
qcGen = forall s. HasSubState s => s -> SubState s
getSubState s
prepState
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
, impLog :: Doc AnsiStyle
impLog = forall a. Monoid a => a
mempty
, impGen :: QCGen
impGen = QCGen
qcGen
, impEvents :: [SomeSTSEvent era]
impEvents = forall a. Monoid a => a
mempty
}
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure
LedgerEnv
{ ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
slotNo
, 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
}
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
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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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 (HASH c) EraIndependentTxBody)
, ShelleyEraScript (ShelleyEra c)
) =>
ShelleyEraImp (ShelleyEra c)
where
initGenesis :: forall s (m :: * -> *).
(HasKeyPairs s (EraCrypto (ShelleyEra c)), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (Genesis (ShelleyEra c))
initGenesis =
forall (f :: * -> *) a. Applicative f => a -> f a
pure
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) => String -> m t
iso8601ParseM String
"2017-09-23T21:44:51Z"
, sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123456
, sgNetworkId :: Network
sgNetworkId = Network
Testnet
, sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
5 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
, sgSecurityParam :: Word64
sgSecurityParam = Word64
2160
, sgEpochLength :: EpochSize
sgEpochLength = EpochSize
4320
, 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
ppKeyDepositL 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
,
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
}
initNewEpochState :: forall s (m :: * -> *).
(HasKeyPairs s (EraCrypto (ShelleyEra c)), MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (NewEpochState (ShelleyEra c))
initNewEpochState = do
ShelleyGenesis c
shelleyGenesis <- forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasStatefulGen (StateGenM s) 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)))
-> 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 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 => String -> a
error String
"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
impWitsVKeyNeeded ::
EraUTxO era =>
TxBody era ->
ImpTestM
era
( Set.Set (BootstrapAddress (EraCrypto era))
, Set.Set (KeyHash 'Witness (EraCrypto era))
)
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 -> IORef (ImpTestState era)
iteState :: !(IORef (ImpTestState era))
, forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup :: Tx era -> ImpTestM era (Tx era)
, forall era. ImpTestEnv era -> Int
iteQuickCheckSize :: !Int
, forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures :: !Bool
}
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})
newtype ImpTestM era a = ImpTestM {forall era a. ImpTestM era a -> ReaderT (ImpTestEnv era) IO a
unImpTestM :: ReaderT (ImpTestEnv era) IO a}
deriving
( forall a b. a -> ImpTestM era b -> ImpTestM era a
forall a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
forall era a b. a -> ImpTestM era b -> ImpTestM era a
forall era a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ImpTestM era b -> ImpTestM era a
$c<$ :: forall era a b. a -> ImpTestM era b -> ImpTestM era a
fmap :: forall a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
$cfmap :: forall era a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
Functor
, forall era. Functor (ImpTestM era)
forall a. a -> ImpTestM era a
forall era a. a -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall era a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
forall a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
forall era a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
$c<* :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
*> :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
$c*> :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
liftA2 :: forall a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
$cliftA2 :: forall era a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
<*> :: forall a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
$c<*> :: forall era a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
pure :: forall a. a -> ImpTestM era a
$cpure :: forall era a. a -> ImpTestM era a
Applicative
, forall era. Applicative (ImpTestM era)
forall a. a -> ImpTestM era a
forall era a. a -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall era a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ImpTestM era a
$creturn :: forall era a. a -> ImpTestM era a
>> :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
$c>> :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
>>= :: forall a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
$c>>= :: forall era a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
Monad
, forall era. Monad (ImpTestM era)
forall a. IO a -> ImpTestM era a
forall era a. IO a -> ImpTestM era a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ImpTestM era a
$cliftIO :: forall era a. IO a -> ImpTestM era a
MonadIO
, forall era. MonadIO (ImpTestM era)
forall b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
forall era b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
$cwithRunInIO :: forall era b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
MonadUnliftIO
, MonadReader (ImpTestEnv era)
)
instance (Testable a, ShelleyEraImp era) => Testable (ImpTestM era a) where
property :: ImpTestM era a -> Property
property ImpTestM era a
m = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSize ->
forall prop. Testable prop => IO prop -> Property
ioProperty forall a b. (a -> b) -> a -> b
$ do
ImpTestState era
impTestState <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasSubState s, SubState s ~ StateGen QCGen,
HasStatefulGen (StateGenM s) m) =>
m (ImpTestState era)
initImpTestState (forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState @(EraCrypto era) (forall a. a -> Maybe a
Just QCGen
qcGen))
forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM (forall a. a -> Maybe a
Just Int
qcSize) ImpTestState era
impTestState ImpTestM era a
m
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)
instance MonadFail (ImpTestM era) where
fail :: forall a. String -> ImpTestM era a
fail = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure
instance MonadState (ImpTestState era) (ImpTestM era) where
get :: ImpTestM era (ImpTestState era)
get = forall era a. ReaderT (ImpTestEnv era) IO a -> ImpTestM era a
ImpTestM forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestEnv era -> IORef (ImpTestState era)
iteState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask
put :: ImpTestState era -> ImpTestM era ()
put ImpTestState era
x = forall era a. ReaderT (ImpTestEnv era) IO a -> ImpTestM era a
ImpTestM forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IORef a -> a -> IO ()
writeIORef ImpTestState era
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestEnv era -> IORef (ImpTestState era)
iteState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask
instance (ShelleyEraImp era, Testable prop) => Example (ImpTestM era prop) where
type Arg (ImpTestM era prop) = ImpTestState era
evaluateExample :: ImpTestM era prop
-> Params
-> (ActionWith (Arg (ImpTestM era prop)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpTestM era prop
impTest =
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> ImpTestM era prop
impTest)
instance (ShelleyEraImp era, Arbitrary a, Show a, Testable prop) => Example (a -> ImpTestM era prop) where
type Arg (a -> ImpTestM era prop) = ImpTestState era
evaluateExample :: (a -> ImpTestM era prop)
-> Params
-> (ActionWith (Arg (a -> ImpTestM era prop)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> ImpTestM era prop
impTest Params
params ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook ProgressCallback
progressCallback =
let runImpTestExample :: ImpTestState era -> Property
runImpTestExample ImpTestState era
s = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ \a
x -> do
let args :: Args
args = Params -> Args
paramsQuickCheckArgs Params
params
(Maybe (QCGen, Int)
r, prop
testable, Doc AnsiStyle
logs) <- forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM (forall era.
Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen Params
params ImpTestState era
s) forall a b. (a -> b) -> a -> b
$ do
prop
t <- a -> ImpTestM era prop
impTest a
x
Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
StateGen QCGen
qcGen <- forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (g, g)
split
Doc AnsiStyle
logs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> Doc AnsiStyle
impLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (QCGen
qcGen, Int
qcSize), prop
t, Doc AnsiStyle
logs)
let params' :: Params
params' = Params
params {paramsQuickCheckArgs :: Args
paramsQuickCheckArgs = Args
args {replay :: Maybe (QCGen, Int)
replay = Maybe (QCGen, Int)
r, chatty :: Bool
chatty = Bool
False}}
Result
res <-
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample
(forall prop. Testable prop => String -> prop -> Property
counterexample (Doc AnsiStyle -> String
ansiDocToString Doc AnsiStyle
logs) prop
testable)
Params
params'
(\ActionWith (Arg Property)
f -> ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook (\Arg (a -> ImpTestM era prop)
_st -> ActionWith (Arg Property)
f ()))
ProgressCallback
progressCallback
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Result -> ResultStatus
resultStatus Result
res
in forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpTestState era -> Property
runImpTestExample Params
params ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook ProgressCallback
progressCallback
instance MonadGen (ImpTestM era) where
liftGen :: forall a. Gen a -> ImpTestM era a
liftGen (MkGen QCGen -> Int -> a
f) = do
Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
StateGen QCGen
qcGen <- forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (g, g)
split
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ QCGen -> Int -> a
f QCGen
qcGen Int
qcSize
variant :: forall n a. Integral n => n -> ImpTestM era a -> ImpTestM era a
variant n
n ImpTestM era a
action = do
forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (\(StateGen QCGen
qcGen) -> ((), forall s. s -> StateGen s
StateGen (forall a. Splittable a => Integer -> a -> a
integerVariant (forall a. Integral a => a -> Integer
toInteger n
n) QCGen
qcGen)))
ImpTestM era a
action
sized :: forall a. (Int -> ImpTestM era a) -> ImpTestM era a
sized Int -> ImpTestM era a
f = do
Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
Int -> ImpTestM era a
f Int
qcSize
resize :: forall a. Int -> ImpTestM era a -> ImpTestM era a
resize Int
n = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ImpTestEnv era
env -> ImpTestEnv era
env {iteQuickCheckSize :: Int
iteQuickCheckSize = Int
n})
choose :: forall a. Random a => (a, a) -> ImpTestM era a
choose (a, a)
r = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (a, a)
r)
instance HasStatefulGen (StateGenM (ImpTestState era)) (ImpTestM era) where
askStatefulGen :: ImpTestM era (StateGenM (ImpTestState era))
askStatefulGen = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall s. StateGenM s
StateGenM
instance HasSubState (ImpTestState era) where
type SubState (ImpTestState era) = StateGen QCGen
getSubState :: ImpTestState era -> SubState (ImpTestState era)
getSubState = forall s. s -> StateGen s
StateGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestState era -> QCGen
impGen
setSubState :: ImpTestState era -> SubState (ImpTestState era) -> ImpTestState era
setSubState ImpTestState era
s (StateGen QCGen
g) = ImpTestState era
s {impGen :: QCGen
impGen = QCGen
g}
impSetSeed :: Int -> ImpTestM era ()
impSetSeed :: forall era. Int -> ImpTestM era ()
impSetSeed Int
seed = forall s (m :: * -> *).
(HasSubState s, MonadState s m) =>
SubState s -> m ()
setSubStateM forall a b. (a -> b) -> a -> b
$ forall s. s -> StateGen s
StateGen forall a b. (a -> b) -> a -> b
$ Int -> QCGen
mkQCGen Int
seed
applyParamsQCGen :: Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen :: forall era.
Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen Params
params ImpTestState era
impTestState =
case Args -> Maybe (QCGen, Int)
replay (Params -> Args
paramsQuickCheckArgs Params
params) of
Maybe (QCGen, Int)
Nothing -> (forall a. Maybe a
Nothing, ImpTestState era
impTestState)
Just (QCGen
qcGen, Int
qcSize) -> (forall a. a -> Maybe a
Just Int
qcSize, forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impTestState QCGen
qcGen)
mixinCurrentGen :: ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen :: forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impTestState QCGen
qcGen =
ImpTestState era
impTestState {impGen :: QCGen
impGen = forall a. Splittable a => Integer -> a -> a
integerVariant (forall a b. (a, b) -> a
fst (forall a g. (Random a, RandomGen g) => g -> (a, g)
Random.random (forall era. ImpTestState era -> QCGen
impGen ImpTestState era
impTestState))) QCGen
qcGen}
evalImpTestGenM :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO b)
evalImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO b)
evalImpTestGenM ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState
evalImpTestM ::
ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM Maybe Int
qc ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qc ImpTestState era
impState
execImpTestGenM ::
ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era))
execImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era))
execImpTestGenM ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState
emptyImpPrepState :: Maybe QCGen -> ImpPrepState c
emptyImpPrepState :: forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState Maybe QCGen
mQCGen =
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
, impPrepGen :: QCGen
impPrepGen = forall a. a -> Maybe a -> a
fromMaybe (Int -> QCGen
mkQCGen Int
2024) Maybe QCGen
mQCGen
}
execImpTestM ::
ShelleyEraImp era =>
Maybe Int ->
ImpTestState era ->
ImpTestM era b ->
IO (ImpTestState era)
execImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (ImpTestState era)
execImpTestM Maybe Int
qcSize ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qcSize ImpTestState era
impState
runImpTestGenM_ :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO ())
runImpTestGenM_ :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO ())
runImpTestGenM_ ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState
runImpTestM_ ::
ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO ()
runImpTestM_ :: forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO ()
runImpTestM_ Maybe Int
qcSize ImpTestState era
impState = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qcSize ImpTestState era
impState
runImpTestGenM ::
ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState ImpTestM era b
m =
forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSz -> forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM (forall a. a -> Maybe a
Just Int
qcSz) (forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impState QCGen
qcGen) ImpTestM era b
m
runImpTestM ::
ShelleyEraImp era =>
Maybe Int ->
ImpTestState era ->
ImpTestM era b ->
IO (b, ImpTestState era)
runImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
mQCSize ImpTestState era
impState ImpTestM era b
action = do
let qcSize :: Int
qcSize = forall a. a -> Maybe a -> a
fromMaybe Int
30 Maybe Int
mQCSize
IORef (ImpTestState era)
ioRef <- forall a. a -> IO (IORef a)
newIORef ImpTestState era
impState
let
env :: ImpTestEnv era
env =
ImpTestEnv
{ iteState :: IORef (ImpTestState era)
iteState = IORef (ImpTestState era)
ioRef
, iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx
, iteQuickCheckSize :: Int
iteQuickCheckSize = Int
qcSize
, iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
True
}
b
res <-
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall era a. ImpTestM era a -> ReaderT (ImpTestEnv era) IO a
unImpTestM (forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ImpTestM era b
action)) ImpTestEnv era
env forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
exc -> do
Doc AnsiStyle
logs <- forall era. ImpTestState era -> Doc AnsiStyle
impLog forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (ImpTestState era)
ioRef
let [Doc ann]
x <?> :: [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe a
my = case Maybe a
my of
Maybe a
Nothing -> [Doc ann]
x
Just a
y -> [Doc ann]
x forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty a
y]
uncaughtException :: [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header e
excThrown =
String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$
Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$
forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
[Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ String
"Uncaught Exception: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException e
excThrown]
fromHUnitFailure :: [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header (HUnitFailure Maybe SrcLoc
mSrcLoc FailureReason
failReason) =
case FailureReason
failReason of
Reason String
msg ->
Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) forall a b. (a -> b) -> a -> b
$
String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$
Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$
forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
[Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
ExpectedButGot Maybe String
mMsg String
expected String
got ->
Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) forall a b. (a -> b) -> a -> b
$
Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mMsg))) String
expected String
got
adjustFailureReason :: [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header = \case
H.Failure Maybe Location
mLoc FailureReason
failureReason ->
Maybe Location -> FailureReason -> ResultStatus
H.Failure Maybe Location
mLoc forall a b. (a -> b) -> a -> b
$
case FailureReason
failureReason of
FailureReason
H.NoReason ->
String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
"NoReason"]
H.Reason String
msg ->
String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
H.ColorizedReason String
msg ->
String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty String
msg]
H.ExpectedButGot Maybe String
mPreface String
expected String
actual ->
Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mPreface))) String
expected String
actual
H.Error Maybe String
mInfo SomeException
excThrown -> forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mInfo) SomeException
excThrown
ResultStatus
result -> ResultStatus
result
newExc :: ResultStatus
newExc
| Just HUnitFailure
hUnitExc <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle
logs] HUnitFailure
hUnitExc
| Just ResultStatus
hspecFailure <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle
logs] ResultStatus
hspecFailure
| Just (ImpException [Doc AnsiStyle]
ann SomeException
excThrown) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc =
let annLen :: Int
annLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc AnsiStyle]
ann
header :: [Doc AnsiStyle]
header =
Doc AnsiStyle
logs
forall a. a -> [a] -> [a]
: [ let prefix :: Doc AnsiStyle
prefix
| Int
annLen forall a. Ord a => a -> a -> Bool
<= Int
1 = Doc AnsiStyle
"╺╸"
| Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = Doc AnsiStyle
"┏╸"
| Int
n forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
annLen = forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗━╸"
| Bool
otherwise = forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗┳╸"
in forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
prefix forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) Doc AnsiStyle
a
| (Int
n, Doc AnsiStyle
a) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Doc AnsiStyle]
ann
]
forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle
""]
in case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
Just HUnitFailure
hUnitExc -> [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header HUnitFailure
hUnitExc
Maybe HUnitFailure
Nothing ->
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
Just ResultStatus
hspecFailure -> [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header ResultStatus
hspecFailure
Maybe ResultStatus
Nothing -> Maybe Location -> FailureReason -> ResultStatus
H.Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header SomeException
excThrown
| Bool
otherwise = Maybe Location -> FailureReason -> ResultStatus
H.Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle
logs] SomeException
exc
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ResultStatus
newExc
ImpTestState era
endState <- forall a. IORef a -> IO a
readIORef IORef (ImpTestState era)
ioRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
res, ImpTestState era
endState)
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)
rewardAcount = 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)
rewardAcount
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) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected a reward account: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
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 => String -> a
error String
"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
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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
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
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))
-> NativeScript era
-> ImpTestM
era
(Maybe
(Map
(KeyHash 'Witness (EraCrypto era))
(KeyPair 'Witness (EraCrypto era))))
impSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto era))
addrWitHashes) (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))
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
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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))
-> NativeScript era
-> ImpTestM
era
(Maybe
(Map
(KeyHash 'Witness (EraCrypto era))
(KeyPair 'Witness (EraCrypto era))))
impSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto era))
curAddrWits) [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 => Tx era -> ImpTestM era (Tx era)
fixupTxOuts :: forall era. ShelleyEraImp era => 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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"fixupFees" forall a b. (a -> b) -> a -> b
$ do
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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
(KeyHash 'Staking (EraCrypto era)
_, KeyPair 'Staking (EraCrypto era)
kpStaking) <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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 -> ImpTestM era 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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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 era. HasCallStack => String -> ImpTestM era ()
logString String
"Validating changeBeforeFee"
Coin
changeBeforeFee <- forall {a} {era}. (Val a, ToExpr a) => a -> ImpTestM era 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 era. HasCallStack => String -> ImpTestM era ()
logString String
"Validating change"
Coin
change <- forall {a} {era}. (Val a, ToExpr a) => a -> ImpTestM era 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
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
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 (AuxiliaryData 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 => 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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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
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 => String -> a
error (String
"Expected at least 1 output after submitting tx: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
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
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 => String -> a
error String
"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
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
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 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
AssertionsAll
}
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 :: String
ruleName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
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) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines forall a b. (a -> b) -> a -> b
$
(String
"Failed to run " forall a. Semigroup a => a -> a -> a
<> String
ruleName forall a. Semigroup a => a -> a -> a
<> String
":") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
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
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
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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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 era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
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) => String -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$
String
"Total ADA in the epoch state is not preserved\n\tpost - pre = "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
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)
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
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
data ImpException = ImpException
{ ImpException -> [Doc AnsiStyle]
ieAnnotation :: [Doc AnsiStyle]
, ImpException -> SomeException
ieThrownException :: SomeException
}
deriving (Int -> ImpException -> ShowS
[ImpException] -> ShowS
ImpException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImpException] -> ShowS
$cshowList :: [ImpException] -> ShowS
show :: ImpException -> String
$cshow :: ImpException -> String
showsPrec :: Int -> ImpException -> ShowS
$cshowsPrec :: Int -> ImpException -> ShowS
Show)
instance Exception ImpException where
displayException :: ImpException -> String
displayException = Doc AnsiStyle -> String
ansiDocToString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpException -> Doc AnsiStyle
prettyImpException
prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException (ImpException [Doc AnsiStyle]
ann SomeException
e) =
forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ [Doc AnsiStyle
"Annotations:"]
, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall ann. Int -> Doc ann -> Doc ann
indent [Int
0, Int
2 ..] [Doc AnsiStyle]
ann
, [Doc AnsiStyle
"Failed with Exception:", forall ann. Int -> Doc ann -> Doc ann
indent Int
4 forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall e. Exception e => e -> String
displayException SomeException
e)]
]
impAnn :: NFData a => String -> ImpTestM era a -> ImpTestM era a
impAnn :: forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
msg = forall a era.
NFData a =>
Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)
impAnnDoc :: NFData a => Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc :: forall a era.
NFData a =>
Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc Doc AnsiStyle
msg ImpTestM era a
m = do
Doc AnsiStyle
logs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL
a
res <- forall a (m :: * -> *).
(NFData a, MonadUnliftIO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep ImpTestM era a
m forall a b. (a -> b) -> a -> b
$ \SomeException
exc ->
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (ImpException [Doc AnsiStyle]
ann SomeException
origExc) -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException (Doc AnsiStyle
msg forall a. a -> [a] -> [a]
: [Doc AnsiStyle]
ann) SomeException
origExc
Maybe ImpException
Nothing -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException [Doc AnsiStyle
msg] SomeException
exc
forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Doc AnsiStyle
logs
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack :: forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack CallStack
callStack Doc AnsiStyle
entry = forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
stack forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc AnsiStyle
entry forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line)
where
prettySrcLoc' :: SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc {Int
String
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} =
forall ann. [Doc ann] -> Doc ann
hcat
[ forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
c) Doc AnsiStyle
d
| (Color
c, Doc AnsiStyle
d) <-
[ (Color
Yellow, Doc AnsiStyle
"[")
, (Color
Blue, forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocModule)
, (Color
Yellow, Doc AnsiStyle
":")
, (Color
Magenta, forall a ann. Pretty a => a -> Doc ann
pretty Int
srcLocStartLine)
, (Color
Yellow, Doc AnsiStyle
"]")
]
]
prefix :: Int -> Doc ann
prefix Int
n = if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 then Doc ann
"" else forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc ann
"└"
stack :: Doc AnsiStyle
stack = forall ann. [Doc ann] -> Doc ann
vsep [forall {ann}. Int -> Doc ann
prefix Int
n forall a. Semigroup a => a -> a -> a
<> SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc
loc | (Int
n, (String
_, SrcLoc
loc)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0, Int
2 ..] (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
callStack)]
logDoc :: HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc :: forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc = forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack HasCallStack
?callStack
logString :: HasCallStack => String -> ImpTestM era ()
logString :: forall era. HasCallStack => String -> ImpTestM era ()
logString = forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty
logToExpr :: (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr :: forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr = forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
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
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 era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
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
withImpState ::
ShelleyEraImp era =>
SpecWith (ImpTestState era) ->
Spec
withImpState :: forall era.
ShelleyEraImp era =>
SpecWith (ImpTestState era) -> Spec
withImpState = forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era)
-> SpecWith (ImpTestState era) -> Spec
withImpStateModified forall a. a -> a
id
withImpStateModified ::
forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era) ->
SpecWith (ImpTestState era) ->
Spec
withImpStateModified :: forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era)
-> SpecWith (ImpTestState era) -> Spec
withImpStateModified ImpTestState era -> ImpTestState era
f =
forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll (ImpTestState era -> ImpTestState era
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
HasSubState s, SubState s ~ StateGen QCGen,
HasStatefulGen (StateGenM s) m) =>
m (ImpTestState era)
initImpTestState (forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState @(EraCrypto era) forall a. Maybe a
Nothing))
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 (Hash (HASH (EraCrypto era)) (VerKeyVRF (EraCrypto era)))
freshKeyHashVRF :: forall era.
Era era =>
ImpTestM
era (Hash (HASH (EraCrypto era)) (VerKeyVRF (EraCrypto era)))
freshKeyHashVRF = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
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
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 => String -> a
error forall a b. (a -> b) -> a -> b
$
String
"Could not find a keypair corresponding to: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyHash r c
keyHash
forall a. [a] -> [a] -> [a]
++ String
"\nAlways use `freshKeyHash` to create key hashes."
freshKeyHash ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
freshKeyPair ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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)
freshKeyAddr_ ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (Addr c)
freshKeyAddr_ :: forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, Addr c)
freshKeyAddr
freshKeyAddr ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, Addr c)
freshKeyAddr :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, Addr c)
freshKeyAddr = do
KeyHash 'Payment c
keyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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)
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 => String -> a
error forall a b. (a -> b) -> a -> b
$
String
"Could not find a keypair corresponding to: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BootstrapAddress c
bootAddr
forall a. [a] -> [a] -> [a]
++ String
"\nAlways use `freshByronKeyHash` to create key hashes."
freshByronKeyHash ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshByronKeyHash :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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 :: * -> *).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (BootstrapAddress c)
freshBootstapAddress
freshBootstapAddress ::
(HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
m (BootstrapAddress c)
freshBootstapAddress :: forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn
(String
"Giving " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value era
amount forall a. Semigroup a => a -> a -> a
<> String
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
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
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 ()
%=)
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) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
msg Tx era
tx = forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
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) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
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) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
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) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ (String
"Register Reward Account: " forall a. Semigroup a => a -> a -> a
<> Text -> String
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) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ (String
"Delegate Staking Credential: " forall a. Semigroup a => a -> a -> a
<> Text -> String
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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) 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)
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
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)
case 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) of
Maybe RDPair
Nothing ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
String
"Staking Credential is not found in the state: "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
stakingCredential
forall a. Semigroup a => a -> a -> a
<> String
"\nMake sure you have the reward account registered with `registerRewardAccount` "
forall a. Semigroup a => a -> a -> a
<> String
"or by some other means."
Just RDPair
rd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact (RDPair -> CompactForm Coin
rdReward RDPair
rd)
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
Hash (HASH (EraCrypto era)) (VerKeyVRF (VRF (EraCrypto era)))
vrfHash <- forall era.
Era era =>
ImpTestM
era (Hash (HASH (EraCrypto era)) (VerKeyVRF (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 :: Hash (HASH (EraCrypto era)) (VerKeyVRF (VRF (EraCrypto era)))
ppVrf = Hash (HASH (EraCrypto era)) (VerKeyVRF (VRF (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) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> 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) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"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
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
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)
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
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
>=>)
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)
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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Bool
False
expectTreasury :: HasCallStack => Coin -> ImpTestM era ()
expectTreasury :: forall era. HasCallStack => Coin -> ImpTestM era ()
expectTreasury Coin
c =
forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Coin
treasuryAmt
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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"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 => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Failed to get TxOut for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TxIn (EraCrypto era)
txIn
produceScript ::
ShelleyEraImp era =>
ScriptHash (EraCrypto era) ->
ImpTestM era (TxIn (EraCrypto era))
produceScript :: forall era.
ShelleyEraImp era =>
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 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