From d9fdf4d590c9c0053de29a397e36826dc6ef27c2 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Tue, 27 Apr 2021 17:38:21 -0700 Subject: [PATCH] Generalized the PropertyTests over all Eras. Introduce the class (EraGen era) which provides Era specific code such that modules like ClassifyTraces and TestChain work over the Core.XXX type families. The EraGen class has a bunch of super classes which every instance should meet. Added instances for Shelley, Allegra, Mary Alonzo, and Example. Renamed the files which make EraGen instances to XXXEraGen, so naming is consistent. Made a better someLeaf function for Alonzo era Made sure the PParams costModel can't not be empty. It must have entry for PlutusV1. Made sure that the _d PParam cannot be 0 in Alonzo (leads to deadlock) Still to do, add better Shrinkers (can we add EraGen parametric ones?) --- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 40 +-- .../impl/src/Cardano/Ledger/Alonzo/PParams.hs | 120 ++++++++- .../Cardano/Ledger/Alonzo/PlutusScriptApi.hs | 10 +- .../src/Cardano/Ledger/Alonzo/Rules/Ledger.hs | 3 +- .../src/Cardano/Ledger/Alonzo/Rules/Utxos.hs | 21 +- .../src/Cardano/Ledger/Alonzo/Translation.hs | 65 +---- alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 17 +- .../impl/src/Cardano/Ledger/Alonzo/TxBody.hs | 2 +- .../impl/src/Cardano/Ledger/Alonzo/TxSeq.hs | 35 ++- .../src/Cardano/Ledger/Alonzo/TxWitness.hs | 28 +++ alonzo/test/cardano-ledger-alonzo-test.cabal | 7 + .../Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 232 ++++++++++++++++++ .../Test/Cardano/Ledger/Alonzo/Translation.hs | 2 +- .../test/Test/Cardano/Ledger/Alonzo/Trials.hs | 229 +++++++++++++++++ alonzo/test/test/Tests.hs | 18 ++ cardano-ledger-core/src/Cardano/Ledger/Era.hs | 10 +- example-shelley/src/Cardano/Ledger/Example.hs | 7 +- .../src/Cardano/Ledger/Example/Translation.hs | 1 + .../test/Test/Cardano/Ledger/Example.hs | 23 +- .../impl/src/Cardano/Ledger/ShelleyMA.hs | 26 +- .../src/Cardano/Ledger/ShelleyMA/Timelocks.hs | 13 +- .../src/Cardano/Ledger/ShelleyMA/TxBody.hs | 4 +- .../cardano-ledger-shelley-ma-test.cabal | 4 +- .../Ledger/{Allegra.hs => AllegraEraGen.hs} | 31 ++- .../Cardano/Ledger/{Mary.hs => MaryEraGen.hs} | 88 ++++--- .../Test/Cardano/Ledger/Mary/Translation.hs | 2 +- .../Serialisation/Golden/Encoding.hs | 2 +- shelley-ma/shelley-ma-test/test/Tests.hs | 4 +- .../src/Cardano/Ledger/Pretty.hs | 57 ++++- .../src/Cardano/Ledger/Shelley.hs | 12 +- .../src/Cardano/Ledger/Shelley/Constraints.hs | 5 +- .../src/Shelley/Spec/Ledger/API/Validation.hs | 2 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 17 +- .../src/Shelley/Spec/Ledger/PParams.hs | 4 +- .../src/Shelley/Spec/Ledger/STS/Bbody.hs | 6 +- .../src/Shelley/Spec/Ledger/STS/Chain.hs | 10 +- .../src/Shelley/Spec/Ledger/STS/Newpp.hs | 2 +- .../src/Shelley/Spec/Ledger/STS/Ppup.hs | 2 +- .../src/Shelley/Spec/Ledger/STS/Upec.hs | 6 +- .../src/Shelley/Spec/Ledger/Tx.hs | 17 ++ .../src/Shelley/Spec/Ledger/TxBody.hs | 28 +-- .../bench/BenchValidation.hs | 15 +- .../bench/Shelley/Spec/Ledger/Bench/Gen.hs | 9 +- .../Shelley/Spec/Ledger/Generator/Block.hs | 45 ++-- .../Shelley/Spec/Ledger/Generator/Core.hs | 45 ++-- .../Spec/Ledger/Generator/Delegation.hs | 57 +++-- .../Shelley/Spec/Ledger/Generator/EraGen.hs | 212 ++++++++++++++-- .../Spec/Ledger/Generator/ScriptClass.hs | 11 +- .../Spec/Ledger/Generator/ShelleyEraGen.hs | 25 +- .../Spec/Ledger/Generator/Trace/Chain.hs | 47 ++-- .../Spec/Ledger/Generator/Trace/DCert.hs | 27 +- .../Spec/Ledger/Generator/Trace/Ledger.hs | 41 ++-- .../Shelley/Spec/Ledger/Generator/Update.hs | 129 ++++++---- .../Shelley/Spec/Ledger/Generator/Utxo.hs | 102 ++++---- .../src/Test/Shelley/Spec/Ledger/Utils.hs | 70 ++---- .../Spec/Ledger/Examples/EmptyBlock.hs | 10 +- .../Test/Shelley/Spec/Ledger/PropertyTests.hs | 40 ++- .../test/Test/Shelley/Spec/Ledger/Rewards.hs | 8 + .../Spec/Ledger/Rules/ClassifyTraces.hs | 99 ++++---- .../Shelley/Spec/Ledger/Rules/TestChain.hs | 180 +++++--------- 60 files changed, 1633 insertions(+), 751 deletions(-) create mode 100644 alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs create mode 100644 alonzo/test/test/Test/Cardano/Ledger/Alonzo/Trials.hs rename shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/{Allegra.hs => AllegraEraGen.hs} (85%) rename shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/{Mary.hs => MaryEraGen.hs} (78%) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 44a5af99dc..e843807830 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -38,15 +38,11 @@ import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS, constructVa import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (WrappedShelleyEraFailure)) import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW) import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript) -import Cardano.Ledger.Alonzo.Tx - ( ValidatedTx (..), - body', - wits', - ) -import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (..), vldt') +import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..)) +import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (..)) import Cardano.Ledger.Alonzo.TxInfo (validPlutusdata, validScript) import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo (TxSeq (..), hashTxSeq) -import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey')) +import Cardano.Ledger.Alonzo.TxWitness (TxWitness) import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..), ValidateAuxiliaryData (..)) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC @@ -60,14 +56,13 @@ import Cardano.Ledger.Shelley.Constraints UsesTxOut (..), UsesValue, ) -import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock) +import Cardano.Ledger.ShelleyMA.Timelocks (validateTimelock) import Cardano.Ledger.Tx (Tx (Tx)) import Control.Arrow (left) import Control.Monad (join) import Control.Monad.Except (liftEither, runExcept) import Control.Monad.Reader (runReader) import Control.State.Transition.Extended (TRC (TRC)) -import qualified Data.Set as Set import qualified Shelley.Spec.Ledger.API as API import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import Shelley.Spec.Ledger.LedgerState @@ -91,7 +86,6 @@ import qualified Shelley.Spec.Ledger.STS.Tick as Shelley import qualified Shelley.Spec.Ledger.STS.Upec as Shelley import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure)) import qualified Shelley.Spec.Ledger.Tx as Shelley -import Shelley.Spec.Ledger.TxBody (witKeyHash) -- ===================================================== @@ -136,8 +130,8 @@ instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where $ TRC (env, state, tx) in liftEither . left (API.ApplyTxError . join) $ res - extractTx ValidatedTx {body, wits, auxiliaryData} = - Tx body wits auxiliaryData + extractTx ValidatedTx {body = b, wits = w, auxiliaryData = a} = + Tx b w a instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c) @@ -149,14 +143,7 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where if isPlutusScript script then "\x01" else nativeMultiSigTag -- "\x00" - validateScript (TimelockScript timelock) tx = - evalTimelock - vhks - (vldt' (body' tx)) - timelock - where - vhks = Set.map witKeyHash (txwitsVKey' (wits' tx)) - -- TODO check if instead we should filter plutus scripts before calling + validateScript (TimelockScript script) tx = validateTimelock @(AlonzoEra c) script tx validateScript (PlutusScript _) _tx = True -- To run a PlutusScript use Cardano.Ledger.Alonzo.TxInfo(runPLCScript) @@ -189,16 +176,11 @@ type instance Core.PParams (AlonzoEra c) = PParams (AlonzoEra c) type instance Core.Witnesses (AlonzoEra c) = TxWitness (AlonzoEra c) -instance CC.Crypto c => UsesValue (AlonzoEra c) +type instance Core.PParamsDelta (AlonzoEra c) = PParamsUpdate (AlonzoEra c) -instance - (CC.Crypto c) => - UsesPParams (AlonzoEra c) - where - type - PParamsDelta (AlonzoEra c) = - PParamsUpdate (AlonzoEra c) +instance CC.Crypto c => UsesValue (AlonzoEra c) +instance (CC.Crypto c) => UsesPParams (AlonzoEra c) where mergePPUpdates _ = updatePParams instance CC.Crypto c => ValidateAuxiliaryData (AlonzoEra c) c where @@ -279,3 +261,5 @@ type instance Core.EraRule "UPEC" (AlonzoEra c) = Shelley.UPEC (AlonzoEra c) type Self c = AlonzoEra c type Value era = V.Value (EraModule.Crypto era) + +type PParamsDelta era = PParamsUpdate era diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs index f52c241aaf..93ade7a71d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs @@ -28,6 +28,10 @@ module Cardano.Ledger.Alonzo.PParams updatePParams, getLanguageView, LangDepView (..), + retractPP, + extendPP, + ppPParams, + ppPParamsUpdate, ) where @@ -37,15 +41,32 @@ import Cardano.Binary ToCBOR (..), encodePreEncoded, ) -import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.Language (Language (PlutusV1), ppLanguage) import Cardano.Ledger.Alonzo.Scripts ( CostModel, ExUnits (..), Prices (..), + ppCostModel, + ppExUnits, + ppPrices, ) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Era import Cardano.Ledger.Hashes (EraIndependentPParamView) +import Cardano.Ledger.Pretty + ( PDoc, + PrettyA (prettyA), + ppCoin, + ppEpochNo, + ppMap, + ppNatural, + ppNonce, + ppProtVer, + ppRational, + ppRecord, + ppStrictMaybe, + ppUnitInterval, + ) import Cardano.Ledger.SafeHash ( HashAnnotated (..), SafeToHash (..), @@ -85,6 +106,7 @@ import Shelley.Spec.Ledger.BaseTypes ) import Shelley.Spec.Ledger.Orphans () import Shelley.Spec.Ledger.PParams (HKD, ProtVer (..)) +import qualified Shelley.Spec.Ledger.PParams as Shelley (PParams' (..)) import Shelley.Spec.Ledger.Serialization ( FromCBORGroup (..), ToCBORGroup (..), @@ -596,3 +618,99 @@ getLanguageView :: Language -> Maybe (LangDepView era) getLanguageView pp PlutusV1 = PlutusView <$> Map.lookup PlutusV1 (_costmdls pp) + +-- Usefull in tests and in translating from earlier Era to the Alonzo Era. + +-- | Turn an PParams' into a Shelley.Params' +retractPP :: (HKD f Coin) -> PParams' f era2 -> Shelley.PParams' f era1 +retractPP + c + (PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv mnP _ _ _ _ _ _) = + (Shelley.PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv c mnP) + +-- | Given the missing pieces Turn a Shelley.PParams' into an Params' +extendPP :: + Shelley.PParams' f era1 -> + (HKD f Coin) -> + (HKD f (Map Language CostModel)) -> + (HKD f Prices) -> + (HKD f ExUnits) -> + (HKD f ExUnits) -> + (HKD f Natural) -> + PParams' f era2 +extendPP + (Shelley.PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv _ mnP) + ada + cost + price + mxTx + mxBl + mxV = + PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv mnP ada cost price mxTx mxBl mxV + +-- ====================================================== +-- Pretty instances + +ppPParams :: PParams' Identity era -> PDoc +ppPParams (PParams feeA feeB mbb mtx mbh kd pd em no a0 rho tau d ex pv mpool ada cost prices mxEx mxBEx mxV) = + ppRecord + "PParams" + [ ("minfeeA", ppNatural feeA), + ("minfeeB", ppNatural feeB), + ("maxBBSize", ppNatural mbb), + ("maxTxSize", ppNatural mtx), + ("maxBHSize", ppNatural mbh), + ("keyDeposit", ppCoin kd), + ("poolDeposit", ppCoin pd), + ("eMax", ppEpochNo em), + ("nOpt", ppNatural no), + ("a0", ppRational a0), + ("rho", ppUnitInterval rho), + ("tau", ppUnitInterval tau), + ("d", ppUnitInterval d), + ("extraEntropy", ppNonce ex), + ("protocolVersion", ppProtVer pv), + ("minPoolCost", ppCoin mpool), + ("adaPerWord", ppCoin ada), + ("costmdls", ppMap ppLanguage ppCostModel cost), + ("prices", ppPrices prices), + ("maxTxExUnits", ppExUnits mxEx), + ("maxBlockExUnits", ppExUnits mxBEx), + ("maxValSize", ppNatural mxV) + ] + +instance PrettyA (PParams' Identity era) where + prettyA = ppPParams + +ppPParamsUpdate :: PParams' StrictMaybe era -> PDoc +ppPParamsUpdate (PParams feeA feeB mbb mtx mbh kd pd em no a0 rho tau d ex pv mpool ada cost prices mxEx mxBEx mxV) = + ppRecord + "PParams" + [ ("minfeeA", lift ppNatural feeA), + ("minfeeB", lift ppNatural feeB), + ("maxBBSize", lift ppNatural mbb), + ("maxTxSize", lift ppNatural mtx), + ("maxBHSize", lift ppNatural mbh), + ("keyDeposit", lift ppCoin kd), + ("poolDeposit", lift ppCoin pd), + ("eMax", lift ppEpochNo em), + ("nOpt", lift ppNatural no), + ("a0", lift ppRational a0), + ("rho", lift ppUnitInterval rho), + ("tau", lift ppUnitInterval tau), + ("d", lift ppUnitInterval d), + ("extraEntropy", lift ppNonce ex), + ("protocolVersion", lift ppProtVer pv), + ("minPoolCost", lift ppCoin mpool), + ("adaPerWord", lift ppCoin ada), + ("costmdls", lift (ppMap ppLanguage ppCostModel) cost), + ("prices", lift ppPrices prices), + ("maxTxExUnits", lift ppExUnits mxEx), + ("maxBlockExUnits", lift ppExUnits mxBEx), + ("maxValSize", lift ppNatural mxV) + ] + where + lift pp x = ppStrictMaybe pp x + +instance PrettyA (PParams' StrictMaybe era) where + prettyA = ppPParamsUpdate diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs index 76737408d5..0b8d313cd5 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs @@ -158,7 +158,15 @@ collectTwoPhaseScriptInputs ei sysS pp tx utxo = Just cost -> merge (apply cost) (map redeemer needed) (map getscript needed) (Right []) where txinfo = txInfo ei sysS utxo tx - needed = scriptsNeeded utxo tx + needed = filter knownToNotBe1Phase $ scriptsNeeded utxo tx + -- The formal spec achieves the same filtering as knownToNotBe1Phase + -- by use of the (partial) language function, which is not defined + -- on 1-phase scripts. + knownToNotBe1Phase (_, sh) = + case sh `Map.lookup` (txscripts' $ getField @"wits" tx) of + Just (AlonzoScript.PlutusScript _) -> True + Just (AlonzoScript.TimelockScript _) -> False + Nothing -> True redeemer (sp, _) = case indexedRdmrs tx sp of Just (d, eu) -> Right (sp, d, eu) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs index 15a60b57da..7412f585b6 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs @@ -26,7 +26,6 @@ import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx (..)) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era, TxInBlock) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import Control.State.Transition ( Assertion (..), AssertionViolation (..), @@ -118,7 +117,7 @@ instance Show (Core.AuxiliaryData era), Show (Core.PParams era), Show (Core.Value era), - Show (PParamsDelta era), + Show (Core.PParamsDelta era), DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), Era era, TxInBlock era ~ ValidatedTx era, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index e1cfdd508e..f8a2bc73ac 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -35,7 +35,6 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Mary.Value (Value) import Cardano.Ledger.Rules.ValidationMode ((?!#)) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import qualified Cardano.Ledger.Val as Val import Control.Iterate.SetAlgebra (eval, (∪), (⋪), (◁)) import Control.Monad.Except (MonadError (throwError)) @@ -76,8 +75,8 @@ instance ( Era era, Eq (Core.PParams era), Show (Core.PParams era), - Show (PParamsDelta era), - Eq (PParamsDelta era), + Show (Core.PParamsDelta era), + Eq (Core.PParamsDelta era), Embed (Core.EraRule "PPUP" era) (UTXOS era), Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, @@ -111,8 +110,8 @@ utxosTransition :: Embed (Core.EraRule "PPUP" era) (UTXOS era), Eq (Core.PParams era), Show (Core.PParams era), - Show (PParamsDelta era), - Eq (PParamsDelta era), + Show (Core.PParamsDelta era), + Eq (Core.PParamsDelta era), Core.TxOut era ~ Alonzo.TxOut era, Core.Value era ~ Value (Crypto era), Core.TxBody era ~ Alonzo.TxBody era, @@ -140,8 +139,8 @@ scriptsValidateTransition :: Embed (Core.EraRule "PPUP" era) (UTXOS era), Eq (Core.PParams era), Show (Core.PParams era), - Show (PParamsDelta era), - Eq (PParamsDelta era), + Show (Core.PParamsDelta era), + Eq (Core.PParamsDelta era), Core.Script era ~ Script era, Core.TxBody era ~ Alonzo.TxBody era, Core.TxOut era ~ Alonzo.TxOut era, @@ -193,8 +192,8 @@ scriptsNotValidateTransition :: ( Era era, Eq (Core.PParams era), Show (Core.PParams era), - Show (PParamsDelta era), - Eq (PParamsDelta era), + Show (Core.PParamsDelta era), + Eq (Core.PParamsDelta era), Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era), @@ -301,8 +300,8 @@ constructValidated :: Era era, Eq (Core.PParams era), Show (Core.PParams era), - Show (PParamsDelta era), - Eq (PParamsDelta era), + Show (Core.PParamsDelta era), + Eq (Core.PParamsDelta era), ToCBOR (Core.AuxiliaryData era), Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index c803d1fc63..835d02a7c5 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -19,7 +19,7 @@ import Cardano.Binary ) import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Language (Language) -import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..), PParamsUpdate) +import Cardano.Ledger.Alonzo.PParams (PParams, PParamsUpdate, extendPP) import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits, Prices) import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx (..)) import Cardano.Ledger.Alonzo.TxBody (TxOut (..)) @@ -207,64 +207,15 @@ translateTxOut :: translateTxOut (Shelley.TxOutCompact addr value) = TxOutCompact addr value SNothing +-- extendPP with type: extendPP :: Shelley.PParams' f era1 -> ... -> PParams' f era2 +-- Is general enough to work for both +-- (PParams era) = (PParams' Identity era) and +-- (PParamsUpdate era) = (PParams' StrictMaybe era) + translatePParams :: AlonzoGenesis -> Shelley.PParams (MaryEra c) -> PParams (AlonzoEra c) -translatePParams ctx pp = - PParams - { _minfeeA = API._minfeeA pp, - _minfeeB = API._minfeeB pp, - _maxBBSize = API._maxBBSize pp, - _maxTxSize = API._maxTxSize pp, - _maxBHSize = API._maxBHSize pp, - _keyDeposit = API._keyDeposit pp, - _poolDeposit = API._poolDeposit pp, - _eMax = API._eMax pp, - _nOpt = API._nOpt pp, - _a0 = API._a0 pp, - _rho = API._rho pp, - _tau = API._tau pp, - _d = API._d pp, - _extraEntropy = API._extraEntropy pp, - _protocolVersion = API._protocolVersion pp, - _minPoolCost = API._minPoolCost pp, - --added in Alonzo - _adaPerUTxOWord = adaPerUTxOWord ctx, - _costmdls = costmdls ctx, - _prices = prices ctx, - _maxTxExUnits = maxTxExUnits ctx, - _maxBlockExUnits = maxBlockExUnits ctx, - _maxValSize = maxValSize ctx, - _collateralPercentage = collateralPercentage ctx, - _maxCollateralInputs = maxCollateralInputs ctx - } +translatePParams (AlonzoGenesis ada cost price mxTx mxBl mxV) pp = extendPP pp ada cost price mxTx mxBl mxV translatePParamsUpdate :: Shelley.PParamsUpdate (MaryEra c) -> PParamsUpdate (AlonzoEra c) -translatePParamsUpdate pp = - PParams - { _minfeeA = API._minfeeA pp, - _minfeeB = API._minfeeB pp, - _maxBBSize = API._maxBBSize pp, - _maxTxSize = API._maxTxSize pp, - _maxBHSize = API._maxBHSize pp, - _keyDeposit = API._keyDeposit pp, - _poolDeposit = API._poolDeposit pp, - _eMax = API._eMax pp, - _nOpt = API._nOpt pp, - _a0 = API._a0 pp, - _rho = API._rho pp, - _tau = API._tau pp, - _d = API._d pp, - _extraEntropy = API._extraEntropy pp, - _protocolVersion = API._protocolVersion pp, - _minPoolCost = API._minPoolCost pp, - --added in Alonzo - _adaPerUTxOWord = SNothing, - _costmdls = SNothing, - _prices = SNothing, - _maxTxExUnits = SNothing, - _maxBlockExUnits = SNothing, - _maxValSize = SNothing, - _collateralPercentage = SNothing, - _maxCollateralInputs = SNothing - } +translatePParamsUpdate pp = extendPP pp SNothing SNothing SNothing SNothing SNothing SNothing diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index e10ae3ca65..ec8a4ade63 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -121,7 +121,6 @@ import Cardano.Ledger.SafeHash SafeToHash, hashAnnotated, ) -import Cardano.Ledger.Shelley.Constraints import Cardano.Ledger.Val (Val (coin, (<+>), (<×>))) import Control.DeepSeq (NFData (..)) import qualified Data.ByteString.Lazy as LBS (toStrict) @@ -175,7 +174,7 @@ deriving instance Eq (Core.Script era), Eq (Core.TxBody era), Eq (Core.Value era), - Eq (PParamsDelta era), + Eq (Core.PParamsDelta era), Compactible (Core.Value era) ) => Eq (ValidatedTxRaw era) @@ -187,7 +186,7 @@ deriving instance Show (Core.Script era), Show (Core.TxBody era), Show (Core.Value era), - Show (PParamsDelta era) + Show (Core.PParamsDelta era) ) => Show (ValidatedTxRaw era) @@ -197,7 +196,7 @@ instance NoThunks (Core.Script era), NoThunks (Core.TxBody era), NoThunks (Core.Value era), - NoThunks (PParamsDelta era) + NoThunks (Core.PParamsDelta era) ) => NoThunks (ValidatedTxRaw era) @@ -210,7 +209,7 @@ deriving newtype instance Eq (Core.Script era), Eq (Core.TxBody era), Eq (Core.Value era), - Eq (PParamsDelta era), + Eq (Core.PParamsDelta era), Compactible (Core.Value era) ) => Eq (ValidatedTx era) @@ -222,7 +221,7 @@ deriving newtype instance Show (Core.Script era), Show (Core.TxBody era), Show (Core.Value era), - Show (PParamsDelta era) + Show (Core.PParamsDelta era) ) => Show (ValidatedTx era) @@ -232,7 +231,7 @@ deriving newtype instance NoThunks (Core.Script era), NoThunks (Core.TxBody era), NoThunks (Core.Value era), - NoThunks (PParamsDelta era) + NoThunks (Core.PParamsDelta era) ) => NoThunks (ValidatedTx era) @@ -325,8 +324,8 @@ instance HasField "wits" (ValidatedTx era) (TxWitness era) where -- ========================================================= -- Figure 2: Definitions for Transactions -getCoin :: UsesValue era => TxOut era -> Coin -getCoin (TxOut _ v _) = coin v +getCoin :: (Era era) => TxOut era -> Coin +getCoin txout = coin (getField @"value" txout) -- ======================================================================== -- A WitnessPPDataHash is the hash of two things. The first part comes from diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index 08ac4ba565..2249fc7403 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -68,6 +68,7 @@ import Cardano.Binary import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), DataHash) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Compactible +import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC import Cardano.Ledger.Era (Crypto, Era) @@ -100,7 +101,6 @@ import Cardano.Ledger.SafeHash SafeHash, SafeToHash, ) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), ppValidityInterval) import Cardano.Ledger.Val ( DecodeNonNegative, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs index ccbec67cc4..78ace5f84f 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -33,11 +34,17 @@ import Cardano.Binary ) import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Alonzo.Scripts (Script) -import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx, segwitTx) +import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx, ppTx, segwitTx) import Cardano.Ledger.Alonzo.TxWitness (TxWitness) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era, ValidateScript) import Cardano.Ledger.Hashes (EraIndependentBlockBody) +import Cardano.Ledger.Pretty + ( PDoc, + PrettyA (prettyA), + ppSexp, + ppStrictSeq, + ) import Cardano.Ledger.SafeHash (SafeToHash, originalBytes) import Control.Monad (unless) import Data.ByteString (ByteString) @@ -67,6 +74,8 @@ import Shelley.Spec.Ledger.Serialization encodeFoldableMapEncoder, ) +-- ================================================= + -- $TxSeq -- -- * TxSeq @@ -278,3 +287,27 @@ alignedValidFlags = alignedValidFlags' (-1) Seq.replicate (x - prev - 1) (IsValidating True) Seq.>< IsValidating False Seq.<| alignedValidFlags' x (n - (x - prev)) xs + +-- ======================================= +-- Pretty instances + +ppTxSeq :: + ( PrettyA (Core.Script era), + Era era, + PrettyA (Core.AuxiliaryData era), + PrettyA (Core.TxBody era) + ) => + TxSeq era -> + PDoc +ppTxSeq (TxSeq' xs _ _ _ _) = + ppSexp "Alonzo TxSeq" [ppStrictSeq ppTx xs] + +instance + ( PrettyA (Core.Script era), + Era era, + PrettyA (Core.AuxiliaryData era), + PrettyA (Core.TxBody era) + ) => + PrettyA (TxSeq era) + where + prettyA = ppTxSeq diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs index d5067594b3..6007eafc5a 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs @@ -78,6 +78,7 @@ import Data.Maybe (mapMaybe) import Data.MemoBytes (Mem, MemoBytes (..), memoBytes) import Data.Proxy (Proxy (..)) import Data.Set (Set) +import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics @@ -183,6 +184,21 @@ data TxWitnessRaw era = TxWitnessRaw newtype TxWitness era = TxWitnessConstr (MemoBytes (TxWitnessRaw era)) deriving newtype (SafeToHash, ToCBOR) +instance (Era era, Core.Script era ~ Script era) => Semigroup (TxWitness era) where + (<>) (TxWitnessConstr (Memo (TxWitnessRaw a b c d (Redeemers' e)) _)) y + | (Set.null a && Set.null b && Map.null c && Map.null d && Map.null e) = + y + (<>) y (TxWitnessConstr (Memo (TxWitnessRaw a b c d (Redeemers' e)) _)) + | (Set.null a && Set.null b && Map.null c && Map.null d && Map.null e) = + y + (<>) + (TxWitnessConstr (Memo (TxWitnessRaw a b c d (Redeemers' e)) _)) + (TxWitnessConstr (Memo (TxWitnessRaw u v w x (Redeemers' y)) _)) = + TxWitness (a <> u) (b <> v) (c <> w) (d <> x) (Redeemers (e <> y)) + +instance (Era era, Core.Script era ~ Script era) => Monoid (TxWitness era) where + mempty = TxWitness mempty mempty mempty mempty (Redeemers mempty) + -- ===================================================== -- TxWitness instances @@ -262,6 +278,18 @@ instance instance HasField "txrdmrs" (TxWitness era) (Redeemers era) where getField (TxWitnessConstr (Memo (TxWitnessRaw _ _ _ _ r) _)) = r +instance + (Crypto era ~ crypto) => + HasField "addrWits" (TxWitness era) (Set (WitVKey 'Witness crypto)) + where + getField (TxWitnessConstr (Memo (TxWitnessRaw w _ _ _ _) _)) = w + +instance + (Core.Script era ~ script, Crypto era ~ crypto) => + HasField "scriptWits" (TxWitness era) (Map (ScriptHash crypto) script) + where + getField (TxWitnessConstr (Memo (TxWitnessRaw _ _ s _ _) _)) = s + -------------------------------------------------------------------------------- -- Serialisation -------------------------------------------------------------------------------- diff --git a/alonzo/test/cardano-ledger-alonzo-test.cabal b/alonzo/test/cardano-ledger-alonzo-test.cabal index a2e63e29fd..34564e6980 100644 --- a/alonzo/test/cardano-ledger-alonzo-test.cabal +++ b/alonzo/test/cardano-ledger-alonzo-test.cabal @@ -38,15 +38,21 @@ library exposed-modules: Test.Cardano.Ledger.Alonzo.Serialisation.Generators + Test.Cardano.Ledger.Alonzo.AlonzoEraGen build-depends: + cardano-binary, cardano-ledger-alonzo, cardano-ledger-core, cardano-ledger-shelley-ma-test, + cardano-ledger-shelley-ma, + cardano-slotting, containers, + hashable, plutus-tx, QuickCheck, shelley-spec-ledger-test, shelley-spec-ledger, + strict-containers, text, hs-source-dirs: lib @@ -59,6 +65,7 @@ test-suite cardano-ledger-alonzo-test hs-source-dirs: test other-modules: + Test.Cardano.Ledger.Alonzo.Trials Test.Cardano.Ledger.Alonzo.Golden Test.Cardano.Ledger.Alonzo.Serialisation.Tripping Test.Cardano.Ledger.Alonzo.Examples.Bbody diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs new file mode 100644 index 0000000000..a1bc9ba5d0 --- /dev/null +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | AlonzoEra instances for EraGen and ScriptClass +module Test.Cardano.Ledger.Alonzo.AlonzoEraGen where + +import Cardano.Binary (serializeEncoding', toCBOR) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Data as Alonzo (AuxiliaryData (..), Data (..)) +import Cardano.Ledger.Alonzo.Language (Language (PlutusV1)) +import Cardano.Ledger.Alonzo.PParams (PParams' (..)) +import qualified Cardano.Ledger.Alonzo.PParams as Alonzo (PParams, extendPP, retractPP) +import Cardano.Ledger.Alonzo.Rules.Utxo (utxoEntrySize) +import Cardano.Ledger.Alonzo.Scripts as Alonzo (CostModel (..), ExUnits (..), Prices (..), Script (..)) +import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx (..)) +import Cardano.Ledger.Alonzo.TxBody (TxBody (..), TxOut (..)) +import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxWitness (..)) +import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) +import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.Core as Core (PParams, PParamsDelta, Script) +import qualified Cardano.Ledger.Crypto as CC +import Cardano.Ledger.Era (Crypto, Era (..)) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Mary.Value (policies) +import Cardano.Ledger.ShelleyMA.AuxiliaryData as Mary (pattern AuxiliaryData) +import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) +import Cardano.Ledger.Tx (Tx (Tx)) +import Cardano.Ledger.Val ((<+>), (<×>)) +import Cardano.Slotting.Slot (SlotNo (..)) +import Control.Monad (replicateM) +import Data.Hashable (hash) +import qualified Data.List as List +import Data.Map as Map +import Data.Proxy (Proxy (..)) +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as Seq (fromList) +import Data.Set as Set +import GHC.Records (HasField (..)) +import qualified PlutusTx as Plutus +import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe (..)) +import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (Witness)) +import Shelley.Spec.Ledger.PParams (Update) +import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl) +import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval) +import Test.Cardano.Ledger.MaryEraGen (addTokens, genMint, maryGenesisValue, policyIndex) +import Test.QuickCheck hiding ((><)) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv, genNatural) +import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..), MinGenTxout (..)) +import Test.Shelley.Spec.Ledger.Generator.ScriptClass (Quantifier (..), ScriptClass (..)) +import Test.Shelley.Spec.Ledger.Generator.Update (genM, genShelleyPParamsDelta) +import qualified Test.Shelley.Spec.Ledger.Generator.Update as Shelley (genPParams) + +-- ================================================================ + +genPair :: Gen a -> Gen b -> Gen (a, b) +genPair x y = do a <- x; b <- y; pure (a, b) + +genPlutusData :: Gen Plutus.Data +genPlutusData = resize 5 (sized gendata) + where + gendata n + | n > 0 = + oneof + [ (Plutus.I <$> arbitrary), + (Plutus.B <$> arbitrary), + (Plutus.Map <$> listOf (genPair (gendata (n `div` 2)) (gendata (n `div` 2)))), + (Plutus.Constr <$> arbitrary <*> listOf (gendata (n `div` 2))), + (Plutus.List <$> listOf (gendata (n `div` 2))) + ] + gendata _ = oneof [Plutus.I <$> arbitrary, Plutus.B <$> arbitrary] + +genSet :: Ord a => Gen a -> Gen (Set a) +genSet gen = + frequency + [ (1, pure Set.empty), + (2, Set.fromList <$> sequence [gen]), + (1, Set.fromList <$> sequence [gen, gen]) + ] + +genAux :: forall c. Mock c => Constants -> Gen (StrictMaybe (Alonzo.AuxiliaryData (AlonzoEra c))) +genAux constants = + do + maybeAux <- genEraAuxiliaryData @(MaryEra c) constants + case maybeAux of + SNothing -> pure SNothing + SJust (Mary.AuxiliaryData x y) -> + SJust + <$> ( Alonzo.AuxiliaryData + <$> pure x + <*> pure (TimelockScript <$> y) + <*> genSet (Alonzo.Data <$> genPlutusData) + ) + +instance CC.Crypto c => ScriptClass (AlonzoEra c) where + -- basescript _ key = TimelockScript (basescript (Proxy @(MaryEra c)) key) -- The old style from Mary + basescript proxy key = TimelockScript (someLeaf proxy key) + isKey _ (TimelockScript x) = isKey (Proxy @(MaryEra c)) x + isKey _ (PlutusScript _) = Nothing + quantify _ (TimelockScript x) = fmap TimelockScript (quantify (Proxy @(MaryEra c)) x) + quantify _ x = Leaf x + unQuantify _ quant = TimelockScript $ unQuantify (Proxy @(MaryEra c)) (fmap unTime quant) + +unTime :: Alonzo.Script era -> Timelock (Crypto era) +unTime (TimelockScript x) = x +unTime (PlutusScript _) = error "Plutus in Timelock" + +genAlonzoTxBody :: + forall c. + Mock c => + GenEnv (AlonzoEra c) -> + Core.PParams (AlonzoEra c) -> + SlotNo -> + Set.Set (TxIn c) -> + StrictSeq (TxOut (AlonzoEra c)) -> + StrictSeq (DCert c) -> + Wdrl c -> + Coin -> + StrictMaybe (Update (AlonzoEra c)) -> + StrictMaybe (AuxiliaryDataHash c) -> + Gen (TxBody (AlonzoEra c), [Core.Script (AlonzoEra c)]) +genAlonzoTxBody _genenv pparams currentslot input txOuts certs wdrls fee updates auxDHash = do + _low <- genM (genSlotAfter currentslot) + _high <- genM (genSlotAfter (currentslot + 50)) + netid <- genM $ pure Testnet -- frequency [(2, pure Mainnet), (1, pure Testnet)] + minted <- genMint + let (minted2, txouts') = case addTokens (Proxy @(AlonzoEra c)) mempty pparams minted txOuts of + Nothing -> (mempty, txOuts) + Just os -> (minted, os) + scriptsFromPolicies = List.map (\p -> (Map.!) policyIndex p) (Set.toList $ policies minted) + validityInterval <- genValidityInterval currentslot + return + ( TxBody + -- non fee inputs + Set.empty -- TODO do something better here (use genenv ?) + -- inputs for fees + input + txouts' + certs + wdrls + fee + validityInterval -- (ValidityInterval SNothing SNothing) -- (ValidityInterval low high) + updates + -- reqSignerHashes + Set.empty -- TODO do something better here + minted2 + -- wppHash + SNothing -- TODO do something better here + auxDHash + netid, + List.map TimelockScript scriptsFromPolicies + ) + +genSlotAfter :: SlotNo -> Gen SlotNo +genSlotAfter currentSlot = do + ttl <- genNatural 50 100 + pure $ currentSlot + SlotNo (fromIntegral ttl) + +-- | Gen an Alonzo PParamsDelta, by adding to a Shelley PParamsData +genAlonzoPParamsDelta :: + forall c. + Constants -> + Alonzo.PParams (AlonzoEra c) -> + Gen (Core.PParamsDelta (AlonzoEra c)) +genAlonzoPParamsDelta constants pp = do + shelleypp <- genShelleyPParamsDelta @(MaryEra c) constants (Alonzo.retractPP (Coin 100) pp) + ada <- genM (Coin <$> choose (1, 5)) + cost <- genM (pure (Map.singleton PlutusV1 (CostModel Map.empty))) -- TODO what is a better assumption for this? + price <- genM (Prices <$> (Coin <$> choose (100, 5000)) <*> (Coin <$> choose (100, 5000))) + mxTx <- genM (ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000))) + mxBl <- genM (ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000))) + mxV <- genM (genNatural 1 10000) + pure (Alonzo.extendPP shelleypp ada cost price mxTx mxBl mxV) + +genAlonzoPParams :: + forall c. + Constants -> + Gen (Core.PParams (AlonzoEra c)) +genAlonzoPParams constants = do + shelleypp <- Shelley.genPParams @(MaryEra c) constants -- This ensures that "_d" field is not 0. + ada <- (Coin <$> choose (1, 5)) + cost <- pure (Map.singleton PlutusV1 (CostModel Map.empty)) -- There are no other Languages, and there must be something for PlutusV1 + price <- (Prices <$> (Coin <$> choose (100, 5000)) <*> (Coin <$> choose (100, 5000))) + mxTx <- (ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000))) + mxBl <- (ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000))) + mxV <- (genNatural 10000 50000) -- This can't be too small + pure (Alonzo.extendPP shelleypp ada cost price mxTx mxBl mxV) + +-- | Since Alonzo PParams don't have this field, we have to compute something here. +instance HasField "_minUTxOValue" (Alonzo.PParams (AlonzoEra c)) Coin where + getField _ = Coin 4000 + +instance Mock c => EraGen (AlonzoEra c) where + genEraAuxiliaryData = genAux + genGenesisValue = maryGenesisValue + genEraTxBody = genAlonzoTxBody + updateEraTxBody txb coinx txin txout = + txb {txinputs_fee = txin, txfee = coinx, outputs = txout} + genEraPParamsDelta = genAlonzoPParamsDelta + genEraPParams = genAlonzoPParams + genEraWitnesses setWitVKey mapScriptWit = TxWitness setWitVKey Set.empty mapScriptWit Map.empty (Redeemers Map.empty) + unsafeApplyTx (Tx bod wit auxdata) = ValidatedTx bod wit (IsValidating True) auxdata + +instance Mock c => MinGenTxout (AlonzoEra c) where + calcEraMinUTxO tout pp = (utxoEntrySize tout <×> getField @"_adaPerUTxOWord" pp) + addValToTxOut v (TxOut a u b) = TxOut a (v <+> u) b + genEraTxOut genVal addrs = do + values <- replicateM (length addrs) genVal + let pairs = zip addrs values + makeTxOut (addr, val) = TxOut addr val SNothing + pure (makeTxOut <$> pairs) + +someLeaf :: + forall era. + Era era => + Proxy era -> + KeyHash 'Witness (Crypto era) -> + Timelock (Crypto era) +someLeaf _proxy x = + let n = hash (serializeEncoding' (toCBOR x)) -- We don't really care about the hash, we only + slot = SlotNo (fromIntegral (mod n 200)) -- use it to pseudo-randomly pick a slot and mode + mode = mod n 3 -- mode==0 is a time leaf, mode=1 or 2 is a signature leaf + in case mode of + 0 -> (RequireAnyOf . Seq.fromList) [RequireTimeStart slot, RequireTimeExpire slot] + _ -> RequireSignature x diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs index 191a102df8..138fdb3400 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs @@ -20,7 +20,7 @@ import Cardano.Ledger.Era (TranslateEra (..)) import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as MA import qualified Cardano.Ledger.ShelleyMA.TxBody as MA import qualified Shelley.Spec.Ledger.API as API -import Test.Cardano.Ledger.Allegra () +import Test.Cardano.Ledger.AllegraEraGen () import Test.Cardano.Ledger.EraBuffet ( MaryEra, StandardCrypto, diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Trials.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Trials.hs new file mode 100644 index 0000000000..be3e9b9e3c --- /dev/null +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Trials.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Test.Cardano.Ledger.Alonzo.Trials where + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..), PParamsUpdate) +import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBBODY) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoUTXOW) +import Cardano.Ledger.Alonzo.Scripts (Script (..), ppScript) +import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Crypto as CC (Crypto) +import Cardano.Ledger.Era (Era (Crypto)) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Pretty (PDoc, PrettyA (prettyA)) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.Constraints (UsesTxBody, UsesTxOut) +import Cardano.Slotting.Slot (SlotNo (..)) +import Control.State.Transition.Extended (Embed (..), IRC (..), STS (..)) +import Control.State.Transition.Trace.Generator.QuickCheck (HasTrace, forAllTraceFromInitState) +import Data.Default.Class (Default (def)) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import Shelley.Spec.Ledger.API (ApplyBlock) +import Shelley.Spec.Ledger.API.Protocol (GetLedgerView) +import Shelley.Spec.Ledger.API.Validation (ApplyBlock) +import Shelley.Spec.Ledger.LedgerState (AccountState (..), DPState (..), DState, EpochState (..), LedgerState (..), NewEpochState (..), PState, UTxOState) +import Shelley.Spec.Ledger.PParams (PParams' (..)) +import Shelley.Spec.Ledger.STS.Chain (CHAIN, ChainPredicateFailure (..), ChainState (..), initialShelleyState) +import Shelley.Spec.Ledger.STS.Ledger (LEDGER, LedgerEnv (..), LedgerPredicateFailure (UtxowFailure)) +import Test.Cardano.Ledger.Alonzo.AlonzoEraGen () +import Test.Cardano.Ledger.Alonzo.Examples.Utxow (plutusScriptExamples, utxowExamples) +import Test.Cardano.Ledger.Alonzo.Golden as Golden +import qualified Test.Cardano.Ledger.Alonzo.Serialisation.CDDL as CDDL +import qualified Test.Cardano.Ledger.Alonzo.Serialisation.Tripping as Tripping +import qualified Test.Cardano.Ledger.Alonzo.Translation as Translation +import Test.Cardano.Ledger.EraBuffet (TestCrypto) +import Test.QuickCheck +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Generator.Block (genBlock) +import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..), KeySpace (..), mkBlock) +import Test.Shelley.Spec.Ledger.Generator.EraGen + ( EraGen (..), + genEraAuxiliaryData, + genEraPParamsDelta, + genEraTxBody, + genGenesisValue, + genUtxo0, + updateEraTxBody, + ) +import Test.Shelley.Spec.Ledger.Generator.Presets (genEnv, genesisDelegs0) +import Test.Shelley.Spec.Ledger.Generator.ScriptClass (ScriptClass (..), baseScripts, keyPairs, mkScriptsFromKeyPair, someScripts) +import Test.Shelley.Spec.Ledger.Generator.ShelleyEraGen () +import Test.Shelley.Spec.Ledger.Generator.Trace.Chain (mkGenesisChainState, registerGenesisStaking) +import Test.Shelley.Spec.Ledger.Generator.Trace.Ledger (genAccountState, mkGenesisLedgerState) +import Test.Shelley.Spec.Ledger.Generator.Utxo (genTx) +import Test.Shelley.Spec.Ledger.PropertyTests + ( adaPreservationChain, + collisionFreeComplete, + delegProperties, + minimalPropertyTests, + onlyValidChainSignalsAreGenerated, + onlyValidLedgerSignalsAreGenerated, + poolProperties, + propCompactAddrRoundTrip, + propCompactSerializationAgree, + propDecompactAddrLazy, + propDecompactShelleyLazyAddr, + propertyTests, + relevantCasesAreCovered, + removedAfterPoolreap, + ) +import Test.Shelley.Spec.Ledger.Rules.TestChain + ( adaPreservationChain, + collisionFreeComplete, + delegProperties, + forAllChainTrace, + poolProperties, + removedAfterPoolreap, + ) +import Test.Shelley.Spec.Ledger.Utils + ( ChainProperty, + maxLLSupply, + mkHash, + testGlobals, + ) +import Test.Tasty + +kps = take 10 $ keyPairs @TestCrypto (geConstants ag) + +pretty :: PrettyA x => x -> PDoc +pretty = prettyA + +ppS = ppScript + +ledgerEnv :: forall era. (Default (Core.PParams era)) => LedgerEnv era +ledgerEnv = LedgerEnv (SlotNo 0) 0 def (AccountState (Coin 0) (Coin 0)) + +baz = genTx ag ledgerEnv + +ap :: Proxy (AlonzoEra TestCrypto) +ap = Proxy @(AlonzoEra TestCrypto) + +ag :: GenEnv (AlonzoEra TestCrypto) +ag = genEnv ap + +genstuff :: + (EraGen era, Default (State (Core.EraRule "PPUP" era))) => + proxy era -> + ( GenEnv era -> + ChainState era -> + NewEpochState era -> + EpochState era -> + LedgerState era -> + Core.PParams era -> + Shelley.Spec.Ledger.LedgerState.UTxOState era -> + DPState (Crypto era) -> + DState (Crypto era) -> + PState (Crypto era) -> + Gen b + ) -> + Gen b +genstuff proxy f = + do + let genenv = (genEnv proxy) + either' <- mkGenesisChainState genenv (IRC ()) + case either' of + Left _z -> error ("OOPS") + Right chainstate -> + let newepochstate = chainNes chainstate + epochstate = nesEs newepochstate + ledgerstate = esLState epochstate + pparams = esPp epochstate + utxostate = _utxoState ledgerstate + dpstate = _delegationState ledgerstate + dstate = _dstate dpstate + pstate = _pstate dpstate + in (f genenv chainstate newepochstate epochstate ledgerstate pparams utxostate dpstate dstate pstate) + +genAlonzoTx = genstuff ap (\genv _cs _nep _ep _ls _pp utxo dp _d _p -> genTx genv ledgerEnv (utxo, dp)) + +genShelleyTx = + genstuff + (Proxy @(ShelleyEra TestCrypto)) + (\genv _cs _nep _ep _ls _pp utxo dp _d _p -> genTx genv ledgerEnv (utxo, dp)) + +genAlonzoBlock = genstuff ap (\genv cs _nep _ep _ls _pp _utxo _dp _d _p -> genBlock genv cs) + +genShelleyBlock = genstuff (Proxy @(ShelleyEra TestCrypto)) (\genv cs _nep _ep _ls _pp _utxo _dp _d _p -> genBlock genv cs) + +foo = do + either' <- mkGenesisChainState (genEnv ap) (IRC ()) + case either' of + Left _z -> error ("OOPS") + Right chainstate -> + let newepochstate = chainNes chainstate + epochstate = nesEs newepochstate + ledgerstate = esLState epochstate + pparams = esPp epochstate + utxostate = _utxoState ledgerstate + dpstate = _delegationState ledgerstate + dstate = _dstate dpstate + pstate = _pstate dpstate + in pure chainstate + +chain = generate foo + +env@(GenEnv keys constants) = genEnv (Proxy @(AlonzoEra TestCrypto)) + +-- in scripts n ranges over [0..149] +scripts n = (\(x, y) -> (ppS x, ppS y)) ((ksMSigScripts keys) !! n) + +-- in payscript and stakescript n ranges over [0..29] +payscript n = (\(x, (y, _z)) -> (show x, ppS y)) ((Map.toList (ksIndexedPayScripts keys)) !! n) + +stakescript n = (\(x, (y, _z)) -> (show x, ppS y)) ((Map.toList (ksIndexedStakeScripts keys)) !! n) + +test = defaultMain (minimalPropertyTests @AT) + +bar = do cs <- foo; genBlock ag cs + +acs = mkGenesisChainState ag + +als = mkGenesisLedgerState ag + +instance Embed (AlonzoBBODY (AlonzoEra TestCrypto)) (CHAIN (AlonzoEra TestCrypto)) where + wrapFailed = BbodyFailure + +instance Embed (AlonzoUTXOW (AlonzoEra TestCrypto)) (LEDGER (AlonzoEra TestCrypto)) where + wrapFailed = UtxowFailure + +-- ==================================================================================== + +tests :: TestTree +tests = + testGroup + "Alonzo tests" + [ Tripping.tests, + Translation.tests, + CDDL.tests 5, + Golden.goldenUTxOEntryMinAda, + plutusScriptExamples, + utxowExamples + ] + +{- +alonzoProperty = testGroup + "Alonzo minimal property tests" + [ minimalPropertyTests @(AlonzoEra TestCrypto) + ] +-} + +type AT = AlonzoEra TestCrypto + +type T = TestCrypto + +main :: IO () +main = defaultMain tests diff --git a/alonzo/test/test/Tests.hs b/alonzo/test/test/Tests.hs index fe0686ff25..c2522b5167 100644 --- a/alonzo/test/test/Tests.hs +++ b/alonzo/test/test/Tests.hs @@ -1,13 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + module Main where +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) import Test.Cardano.Ledger.Alonzo.Examples.Bbody (bbodyExamples) import Test.Cardano.Ledger.Alonzo.Examples.Utxow (plutusScriptExamples, utxowExamples) import Test.Cardano.Ledger.Alonzo.Golden as Golden import qualified Test.Cardano.Ledger.Alonzo.Serialisation.CDDL as CDDL import qualified Test.Cardano.Ledger.Alonzo.Serialisation.Tripping as Tripping import qualified Test.Cardano.Ledger.Alonzo.Translation as Translation +import Test.Cardano.Ledger.EraBuffet (TestCrypto) +import Test.QuickCheck +import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Tasty +-- ==================================================================================== + tests :: TestTree tests = testGroup diff --git a/cardano-ledger-core/src/Cardano/Ledger/Era.hs b/cardano-ledger-core/src/Cardano/Ledger/Era.hs index 5e0349cc99..22b894b633 100644 --- a/cardano-ledger-core/src/Cardano/Ledger/Era.hs +++ b/cardano-ledger-core/src/Cardano/Ledger/Era.hs @@ -71,6 +71,8 @@ class -- Script Validation ----------------------------------------------------------------------------- +-- HasField "scriptWits" (ValidatedTx era) (Map.Map (ScriptHash c) script) + -- | Typeclass for script data types. Allows for script validation and hashing. -- You must understand the role of SafeToHash and scriptPrefixTag to make new -- instances. 'scriptPrefixTag' is a magic number representing the tag of the @@ -78,7 +80,10 @@ class -- and the tag is included in the script hash for a script. The safeToHash -- constraint ensures that Scripts are never reserialised. class - (Era era, SafeToHash (Core.Script era)) => + ( Era era, + SafeToHash (Core.Script era), + HasField "body" (TxInBlock era) (Core.TxBody era) + ) => ValidateScript era where scriptPrefixTag :: Core.Script era -> BS.ByteString @@ -133,9 +138,10 @@ class SupportsSegWit era where hashTxSeq :: TxSeq era -> Hash.Hash (CryptoClass.HASH (Crypto era)) EraIndependentBlockBody - -- | The number of segregated components numSegComponents :: Word64 + -- | Use unsafeApplyTx only for Tests. The real applyTx is an STS rule + -- that performs phase 1 validation, as well as the injection into TxInBlock. -------------------------------------------------------------------------------- -- Era translation diff --git a/example-shelley/src/Cardano/Ledger/Example.hs b/example-shelley/src/Cardano/Ledger/Example.hs index 46892a1d65..d65218425c 100644 --- a/example-shelley/src/Cardano/Ledger/Example.hs +++ b/example-shelley/src/Cardano/Ledger/Example.hs @@ -22,6 +22,7 @@ import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (..), ValidateScript (..)) import Cardano.Ledger.Hashes (EraIndependentAuxiliaryData) +import Shelley.Spec.Ledger.PParams() import Cardano.Ledger.SafeHash (makeHashWithExplicitProxys) import Cardano.Ledger.Shelley.Constraints (UsesPParams (..), UsesTxOut (..), UsesValue, UsesTxBody) import Cardano.Ledger.Val (Val ((<->))) @@ -119,6 +120,8 @@ type instance Core.AuxiliaryData (ExampleEra c) = Metadata (ExampleEra c) type instance Core.PParams (ExampleEra c) = SPP.PParams (ExampleEra c) +type instance Core.PParamsDelta (ExampleEra c) = SPP.PParamsUpdate (ExampleEra c) + type instance Core.Witnesses (ExampleEra c) = WitnessSet (ExampleEra c) -------------------------------------------------------------------------------- @@ -129,10 +132,6 @@ instance (CryptoClass.Crypto c) => UsesPParams (ExampleEra c) where - type - PParamsDelta (ExampleEra c) = - SPP.PParamsUpdate (ExampleEra c) - mergePPUpdates _ = SPP.updatePParams nativeMultiSigTag :: BS.ByteString diff --git a/example-shelley/src/Cardano/Ledger/Example/Translation.hs b/example-shelley/src/Cardano/Ledger/Example/Translation.hs index 14c5226be2..0158e529cd 100644 --- a/example-shelley/src/Cardano/Ledger/Example/Translation.hs +++ b/example-shelley/src/Cardano/Ledger/Example/Translation.hs @@ -33,6 +33,7 @@ import Data.Coerce (coerce) import qualified Data.Map.Strict as Map import Shelley.Spec.Ledger.API import Shelley.Spec.Ledger.Tx (decodeWits) +import Shelley.Spec.Ledger.PParams() -------------------------------------------------------------------------------- -- Translation from Shelley to Example diff --git a/example-shelley/test/Test/Cardano/Ledger/Example.hs b/example-shelley/test/Test/Cardano/Ledger/Example.hs index 3e464495b4..96486a349a 100644 --- a/example-shelley/test/Test/Cardano/Ledger/Example.hs +++ b/example-shelley/test/Test/Cardano/Ledger/Example.hs @@ -41,6 +41,7 @@ import Shelley.Spec.Ledger.Slot (SlotNo (..)) import Shelley.Spec.Ledger.Tx ( TxIn (..), TxOut (..), + WitnessSetHKD(WitnessSet) ) import Shelley.Spec.Ledger.TxBody (TxBody (TxBody, _inputs, _outputs, _txfee), Wdrl (..)) import qualified Shelley.Spec.Ledger.STS.Utxo as STS @@ -61,6 +62,11 @@ import Test.Shelley.Spec.Ledger.Generator.ScriptClass import Test.Shelley.Spec.Ledger.Generator.Trace.Chain () import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) +import Test.Shelley.Spec.Ledger.Generator.Update(genShelleyPParamsDelta,genPParams) +import Shelley.Spec.Ledger.PParams(PParams'(..)) +import Test.Shelley.Spec.Ledger.Generator.EraGen(MinGenTxout(..)) +import Cardano.Ledger.Val((<+>)) +import Control.Monad (replicateM) {------------------------------------------------------------------------------ ExampleEra instances for EraGen and ScriptClass @@ -69,7 +75,8 @@ import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) instance ( PraosCrypto c, DSIGN.Signable (DSIGN c) ~ SignableRepresentation, - KES.Signable (KES c) ~ SignableRepresentation + KES.Signable (KES c) ~ SignableRepresentation, + MinGenTxout(ExampleEra c) ) => EraGen (ExampleEra c) where @@ -81,6 +88,9 @@ instance genCoin minGenesisOutputVal maxGenesisOutputVal genEraTxBody _ge = genTxBody genEraAuxiliaryData = genMetadata + genEraPParamsDelta = genShelleyPParamsDelta + genEraPParams = genPParams + genEraWitnesses setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty updateEraTxBody body fee ins outs = body @@ -88,6 +98,8 @@ instance _inputs = ins, _outputs = outs } + unsafeApplyTx x = x + instance CC.Crypto c => ScriptClass (ExampleEra c) where basescript _proxy = RequireSignature @@ -153,3 +165,12 @@ instance Mock c => Arbitrary (TxBody (ExampleEra c)) where instance Mock c => Arbitrary (STS.UtxoPredicateFailure (ExampleEra c)) where arbitrary = genericArbitraryU shrink _ = [] + + +instance Mock c => MinGenTxout (ExampleEra c) where + calcEraMinUTxO _txout pp = (_minUTxOValue pp) + addValToTxOut v (TxOut a u) = TxOut a (v <+> u) + genEraTxOut genVal addrs = do + values <- replicateM (length addrs) genVal + let makeTxOut (addr,val) = TxOut addr val + pure (makeTxOut <$> zip addrs values) \ No newline at end of file diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs index db99efb575..b7f136bae4 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs @@ -44,7 +44,6 @@ import Cardano.Ledger.ShelleyMA.AuxiliaryData ) import Cardano.Ledger.ShelleyMA.Timelocks ( Timelock (..), - ValidityInterval, validateTimelock, ) import Cardano.Ledger.ShelleyMA.TxBody (TxBody) @@ -60,11 +59,12 @@ import qualified Shelley.Spec.Ledger.BlockChain as Shelley bbHash, txSeqTxns, ) -import Shelley.Spec.Ledger.Keys (KeyRole (Witness)) import Shelley.Spec.Ledger.Metadata (validMetadatum) import qualified Shelley.Spec.Ledger.PParams as Shelley import Shelley.Spec.Ledger.Scripts (ScriptHash) -import Shelley.Spec.Ledger.Tx (Tx, TxOut (..), WitVKey, WitnessSet) +import Shelley.Spec.Ledger.Tx (Tx, TxOut (..), WitnessSet) + +-- ======================================== -- | The Shelley Mary/Allegra eras -- The uninhabited type that indexes both the Mary and Allegra Eras. @@ -118,14 +118,10 @@ instance CryptoClass.Crypto c => UsesTxOut (ShelleyMAEra 'Mary c) where instance CryptoClass.Crypto c => UsesTxOut (ShelleyMAEra 'Allegra c) where makeTxOut _ a v = TxOut a v -instance - (MAClass ma c) => - UsesPParams (ShelleyMAEra ma c) - where - type - PParamsDelta (ShelleyMAEra ma c) = - Shelley.PParamsUpdate (ShelleyMAEra ma c) +instance CryptoClass.Crypto c => UsesPParams (ShelleyMAEra 'Mary c) where + mergePPUpdates _ = Shelley.updatePParams +instance CryptoClass.Crypto c => UsesPParams (ShelleyMAEra 'Allegra c) where mergePPUpdates _ = Shelley.updatePParams -------------------------------------------------------------------------------- @@ -158,6 +154,10 @@ type instance Core.Witnesses (ShelleyMAEra (ma :: MaryOrAllegra) c) = WitnessSet (ShelleyMAEra (ma :: MaryOrAllegra) c) +type instance + Core.PParamsDelta (ShelleyMAEra (ma :: MaryOrAllegra) c) = + Shelley.PParamsUpdate (ShelleyMAEra (ma :: MaryOrAllegra) c) + -------------------------------------------------------------------------------- -- Ledger data instances -------------------------------------------------------------------------------- @@ -170,14 +170,12 @@ type instance instance ( CryptoClass.Crypto c, UsesTxBody (ShelleyMAEra ma c), - Core.AnnotatedData (Core.AuxiliaryData (ShelleyMAEra ma c)), - HasField "vldt" (Core.TxBody (ShelleyMAEra ma c)) ValidityInterval, - HasField "addrWits" (Tx (ShelleyMAEra ma c)) (Set.Set (WitVKey 'Witness c)) + Core.AnnotatedData (Core.AuxiliaryData (ShelleyMAEra ma c)) ) => ValidateScript (ShelleyMAEra ma c) where scriptPrefixTag _script = nativeMultiSigTag -- "\x00" - validateScript script tx = validateTimelock script tx + validateScript script tx = validateTimelock @(ShelleyMAEra ma c) script tx -- Uses the default instance of hashScript diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs index c911c41d64..b5f7bca2f2 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs @@ -44,7 +44,7 @@ import Cardano.Binary ) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era +import Cardano.Ledger.Era (Era (Crypto), TxInBlock) import Cardano.Ledger.Pretty ( PDoc, PrettyA (..), @@ -92,10 +92,7 @@ import Shelley.Spec.Ledger.Serialization ( decodeStrictSeq, encodeFoldable, ) -import Shelley.Spec.Ledger.Tx - ( Tx (..), - WitVKey, - ) +import Shelley.Spec.Ledger.Tx (WitVKey) import Shelley.Spec.Ledger.TxBody ( witKeyHash, ) @@ -298,15 +295,13 @@ validateTimelock :: forall era. ( UsesTxBody era, HasField "vldt" (Core.TxBody era) ValidityInterval, - HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era))) + HasField "addrWits" (TxInBlock era) (Set (WitVKey 'Witness (Crypto era))) ) => Timelock (Crypto era) -> - Tx era -> + TxInBlock era -> Bool validateTimelock lock tx = evalFPS @era lock vhks (getField @"body" tx) where - -- THIS IS JUST A STUB. WHO KNOWS IF - -- IT COMPUTES THE RIGHT WITNESS SET. vhks = Set.map witKeyHash (getField @"addrWits" tx) showTimelock :: CC.Crypto crypto => Timelock crypto -> String diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs index c7ca9cd29c..151fc57348 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs @@ -49,7 +49,7 @@ where import Cardano.Binary (Annotator, FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Core (Script, Value) +import Cardano.Ledger.Core (PParamsDelta, Script, Value) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Hashes (EraIndependentTxBody) @@ -69,7 +69,7 @@ import Cardano.Ledger.Pretty ppWdrl, ) import Cardano.Ledger.SafeHash (HashAnnotated, SafeToHash) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta, TransValue) +import Cardano.Ledger.Shelley.Constraints (TransValue) import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), ppValidityInterval) import Cardano.Ledger.Val ( DecodeMint (..), diff --git a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal b/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal index 2e0d798e56..2268e6a677 100644 --- a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal +++ b/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal @@ -44,9 +44,9 @@ library exposed-modules: Test.Cardano.Ledger.TranslationTools Test.Cardano.Ledger.EraBuffet - Test.Cardano.Ledger.Mary + Test.Cardano.Ledger.MaryEraGen Test.Cardano.Ledger.Mary.Golden - Test.Cardano.Ledger.Allegra + Test.Cardano.Ledger.AllegraEraGen Test.Cardano.Ledger.ShelleyMA.TxBody Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs similarity index 85% rename from shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs rename to shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs index 9af3348f9e..edd96f03b8 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs @@ -8,9 +8,11 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -module Test.Cardano.Ledger.Allegra +module Test.Cardano.Ledger.AllegraEraGen ( -- export EraGen instance for AllegraEra and helpers shared with MaryEra quantifyTL, unQuantifyTL, @@ -35,6 +37,8 @@ import Cardano.Ledger.ShelleyMA.TxBody ( TxBody (..), ValidityInterval (ValidityInterval), ) +import Shelley.Spec.Ledger.Tx(pattern WitnessSet) +import Cardano.Ledger.Allegra(AllegraEra) import Cardano.Ledger.Val (Val (zero)) import Cardano.Slotting.Slot (SlotNo (SlotNo)) import Data.Hashable (hash) @@ -44,18 +48,23 @@ import Shelley.Spec.Ledger.API (KeyRole (Witness)) import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) import Shelley.Spec.Ledger.Keys (KeyHash) import Shelley.Spec.Ledger.PParams (PParams, Update) -import Shelley.Spec.Ledger.TxBody (DCert, TxIn, TxOut, Wdrl) -import Test.Cardano.Ledger.EraBuffet (AllegraEra) +import Shelley.Spec.Ledger.TxBody (DCert, TxIn, TxOut(..), Wdrl) import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () import Test.QuickCheck (Gen, arbitrary, frequency) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..), genCoin) -import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..)) +import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..),MinGenTxout(..)) import Test.Shelley.Spec.Ledger.Generator.ScriptClass ( Quantifier (..), ScriptClass (..), ) +import Test.Shelley.Spec.Ledger.Generator.Update(genShelleyPParamsDelta) +import Test.Shelley.Spec.Ledger.Generator.Core(genCoin) +import Test.Shelley.Spec.Ledger.Generator.Update (genPParams) +import Shelley.Spec.Ledger.PParams (PParams' (..)) +import Cardano.Ledger.Val((<+>)) +import Control.Monad (replicateM) -- ========================================================== @@ -84,6 +93,10 @@ instance (CryptoClass.Crypto c, Mock c) => EraGen (AllegraEra c) where genEraAuxiliaryData = genAuxiliaryData updateEraTxBody (TxBody _in _out cert wdrl _txfee vi upd ad forge) fee ins outs = TxBody ins outs cert wdrl fee vi upd ad forge + genEraPParamsDelta = genShelleyPParamsDelta + genEraPParams = genPParams + genEraWitnesses setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty + unsafeApplyTx x = x genTxBody :: forall era. @@ -119,6 +132,14 @@ genTxBody _pparams slot ins outs cert wdrl fee upd ad = do [] -- Allegra does not need any additional script witnesses ) +instance Mock c => MinGenTxout (AllegraEra c) where + calcEraMinUTxO _txout pp = (_minUTxOValue pp) + addValToTxOut v (TxOut a u) = TxOut a (v <+> u) + genEraTxOut genVal addrs = do + values <- replicateM (length addrs) genVal + let makeTxOut (addr,val) = TxOut addr val + pure (makeTxOut <$> zip addrs values) + {------------------------------------------------------------------------------ ShelleyMA helpers, shared by Allegra and Mary ------------------------------------------------------------------------------} diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs similarity index 78% rename from shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs rename to shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs index 3d400fbcd3..322441d96b 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs @@ -7,13 +7,16 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Test.Cardano.Ledger.Mary () where -- export the EraGen instance for MaryEra +-- | Export the EraGen instance for MaryEra, as well as some reusable functions for future Eras +module Test.Cardano.Ledger.MaryEraGen (genMint,maryGenesisValue,policyIndex,addTokens) where + import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Coin (Coin (..)) -import qualified Cardano.Ledger.Core as Core (AuxiliaryData, Value) +import qualified Cardano.Ledger.Core as Core (AuxiliaryData, Value, PParams, TxOut) import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Mary.Value @@ -22,11 +25,6 @@ import Cardano.Ledger.Mary.Value Value (..), policies, ) -import Cardano.Ledger.Shelley.Constraints - ( UsesAuxiliary, - UsesPParams, - UsesValue, - ) import Cardano.Ledger.ShelleyMA.Rules.Utxo (scaledMinDeposit) import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) import Cardano.Ledger.ShelleyMA.TxBody (StrictMaybe, TxBody (TxBody)) @@ -42,7 +40,7 @@ import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) import Shelley.Spec.Ledger.PParams (PParams, PParams' (..), Update) import Shelley.Spec.Ledger.Tx (TxIn, TxOut (..), hashScript) import Shelley.Spec.Ledger.TxBody (DCert, Wdrl) -import Test.Cardano.Ledger.Allegra +import Test.Cardano.Ledger.AllegraEraGen ( genValidityInterval, quantifyTL, someLeaf, @@ -54,12 +52,20 @@ import qualified Test.QuickCheck as QC import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..), genInteger) -import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) +import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..),MinGenTxout(..)) import Test.Shelley.Spec.Ledger.Generator.ScriptClass ( ScriptClass (..), exponential, ) import Test.Shelley.Spec.Ledger.Utils (Split (..)) +import Test.Shelley.Spec.Ledger.Generator.Update(genShelleyPParamsDelta) +import Test.Shelley.Spec.Ledger.Generator.Update (genPParams) +import Shelley.Spec.Ledger.Tx(pattern WitnessSet) +import Data.Proxy(Proxy(..)) +import GHC.Records(HasField(getField)) +import Cardano.Ledger.Val((<+>)) +import Control.Monad (replicateM) + {------------------------------------------------------------------------------ EraGen instance for MaryEra - This instance makes it possible to run the @@ -80,12 +86,15 @@ instance (CryptoClass.Crypto c) => ScriptClass (MaryEra c) where unQuantify _ = unQuantifyTL instance (CryptoClass.Crypto c, Mock c) => EraGen (MaryEra c) where - genGenesisValue (GenEnv _ Constants {minGenesisOutputVal, maxGenesisOutputVal}) = - Val.inject . Coin <$> exponential minGenesisOutputVal maxGenesisOutputVal + genGenesisValue = maryGenesisValue genEraTxBody _ge = genTxBody genEraAuxiliaryData = genAuxiliaryData updateEraTxBody (TxBody _in _out cert wdrl _txfee vi upd meta mint) fee ins outs = TxBody ins outs cert wdrl fee vi upd meta mint + genEraPParamsDelta = genShelleyPParamsDelta + genEraPParams = genPParams + genEraWitnesses setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty + unsafeApplyTx x = x genAuxiliaryData :: Mock crypto => @@ -97,6 +106,11 @@ genAuxiliaryData Constants {frequencyTxWithMetadata} = (100 - frequencyTxWithMetadata, pure SNothing) ] +-- | Carefully crafted to apply in any Era where Core.Value is Value +maryGenesisValue :: forall era crypto. CryptoClass.Crypto crypto => GenEnv era -> Gen(Value crypto) +maryGenesisValue (GenEnv _ Constants {minGenesisOutputVal, maxGenesisOutputVal}) = + Val.inject . Coin <$> exponential minGenesisOutputVal maxGenesisOutputVal + -------------------------------------------------------- -- Permissionless Tokens -- -- -- @@ -197,6 +211,7 @@ genYellow = do let an = AssetName . BS.pack $ "yellow" <> show x pure $ (an, y) +-- | Carefully crafted to apply in any Era where Core.Value is Value -- | This map allows us to lookup a minting policy by the policy ID. policyIndex :: CryptoClass.Crypto c => Map (PolicyID c) (Timelock c) policyIndex = @@ -237,32 +252,36 @@ genMint = do -- END Permissionless Tokens -- ------------------------------- --- | Attempt to Add tokens to a non-empty list of transaction outputs. + +-- | Carefully crafted to apply to any Era where Core.Value is Value +-- We attempt to Add tokens to a non-empty list of transaction outputs. -- It will add them to the first output that has enough lovelace -- to meet the minUTxO requirment, if such an output exists. -addTokens :: - ( Core.Value era ~ Value (Crypto era), - EraGen era +addTokens :: forall era. + ( EraGen era, + Core.Value era ~ Value (Crypto era) ) => - PParams era -> + Proxy era -> + StrictSeq (Core.TxOut era) -> -- This is an accumuating parameter + Core.PParams era -> Value (Crypto era) -> - StrictSeq (TxOut era) -> - Maybe (StrictSeq (TxOut era)) -addTokens = addTokens' StrictSeq.Empty - where - addTokens' tooLittleLovelace pparams ts (o@(TxOut a v) :<| os) = - if Val.coin v < scaledMinDeposit v (_minUTxOValue pparams) - then addTokens' (o :<| tooLittleLovelace) pparams ts os - else (Just $ tooLittleLovelace >< TxOut a (v <> ts) <| os) - addTokens' _ _ _ StrictSeq.Empty = Nothing + StrictSeq (Core.TxOut era) -> + Maybe (StrictSeq (Core.TxOut era)) +addTokens proxy tooLittleLovelace pparams ts (txout :<| os) = + let v = getField @"value" txout + in if Val.coin v < scaledMinDeposit v (getField @"_minUTxOValue" pparams) + then addTokens proxy (txout :<| tooLittleLovelace) pparams ts os + else (Just $ tooLittleLovelace >< addValToTxOut @era ts txout <| os) +addTokens _proxy _ _ _ StrictSeq.Empty = Nothing + +-- | This function is only good in the Mary Era genTxBody :: forall era. - ( UsesValue era, + ( EraGen era, Core.Value era ~ Value (Crypto era), - UsesPParams era, - UsesAuxiliary era, - EraGen era + Core.PParams era ~ PParams era, + Core.TxOut era ~ TxOut era ) => PParams era -> SlotNo -> @@ -277,7 +296,7 @@ genTxBody :: genTxBody pparams slot ins outs cert wdrl fee upd meta = do validityInterval <- genValidityInterval slot mint <- genMint - let (mint', outs') = case addTokens pparams mint outs of + let (mint', outs') = case addTokens (Proxy @era) StrictSeq.Empty pparams mint outs of Nothing -> (mempty, outs) Just os -> (mint, os) ps = map (\p -> (Map.!) policyIndex p) (Set.toList $ policies mint) @@ -303,3 +322,12 @@ instance Split (Value era) where ( take (fromIntegral m) ((Value (n `div` m) mp) : (repeat (Value (n `div` m) Map.empty))), Coin (n `rem` m) ) + + +instance Mock c => MinGenTxout (MaryEra c) where + calcEraMinUTxO _txout pp = (_minUTxOValue pp) + addValToTxOut v (TxOut a u) = TxOut a (v <+> u) + genEraTxOut genVal addrs = do + values <- replicateM (length addrs) genVal + let makeTxOut (addr,val) = TxOut addr val + pure (makeTxOut <$> zip addrs values) \ No newline at end of file diff --git a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Translation.hs index 694cd25731..846fb2f798 100644 --- a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Translation.hs +++ b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Translation.hs @@ -16,7 +16,7 @@ import Cardano.Ledger.Era (TranslateEra (..)) import Cardano.Ledger.Mary.Translation () import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as MA import qualified Shelley.Spec.Ledger.API as S -import Test.Cardano.Ledger.Allegra () +import Test.Cardano.Ledger.AllegraEraGen () -- import Allegra EraGen instance import Test.Cardano.Ledger.EraBuffet ( AllegraEra, MaryEra, diff --git a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs index fa73251d68..f16bc86249 100644 --- a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs +++ b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs @@ -17,7 +17,7 @@ import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto (..), ValidateScript (hashScript)) import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..), Value (..)) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) +import Cardano.Ledger.Core(PParamsDelta) import Cardano.Ledger.ShelleyMA.AuxiliaryData (pattern AuxiliaryData) import Cardano.Ledger.ShelleyMA.Timelocks ( Timelock (..), diff --git a/shelley-ma/shelley-ma-test/test/Tests.hs b/shelley-ma/shelley-ma-test/test/Tests.hs index f0f4b03eef..fd90c48880 100644 --- a/shelley-ma/shelley-ma-test/test/Tests.hs +++ b/shelley-ma/shelley-ma-test/test/Tests.hs @@ -4,11 +4,11 @@ module Main where import Shelley.Spec.Ledger.PParams (PParams' (..)) -import Test.Cardano.Ledger.Allegra () +import Test.Cardano.Ledger.AllegraEraGen () import Test.Cardano.Ledger.Allegra.ScriptTranslation (testScriptPostTranslation) import Test.Cardano.Ledger.Allegra.Translation (allegraTranslationTests) import Test.Cardano.Ledger.EraBuffet (AllegraEra, MaryEra, TestCrypto) -import Test.Cardano.Ledger.Mary () +import Test.Cardano.Ledger.MaryEraGen () import Test.Cardano.Ledger.Mary.Examples.MultiAssets (multiAssetsExample) import Test.Cardano.Ledger.Mary.Golden (goldenScaledMinDeposit) import Test.Cardano.Ledger.Mary.Translation (maryTranslationTests) diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Pretty.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Pretty.hs index 8321ab17c5..26a9bc2aa9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Pretty.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Pretty.hs @@ -23,11 +23,12 @@ import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..)) import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..)) import Cardano.Ledger.Compactible (Compactible (..)) +import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Era (Era) +import qualified Cardano.Ledger.Era as Era (TxSeq) import Cardano.Ledger.SafeHash (SafeHash, extractHash) -import Cardano.Ledger.Shelley.Constraints (UsesPParams (PParamsDelta)) import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Slotting.Time (SystemStart (SystemStart)) import Codec.Binary.Bech32 @@ -57,7 +58,14 @@ import Shelley.Spec.Ledger.Address ) import Shelley.Spec.Ledger.Address.Bootstrap (BootstrapWitness (..), ChainCode (..)) import Shelley.Spec.Ledger.BaseTypes (ActiveSlotCoeff, DnsName, FixedPoint, Globals (..), Network (..), Nonce (..), Port (..), StrictMaybe (..), UnitInterval, Url (..), activeSlotLog, activeSlotVal, dnsToText) -import Shelley.Spec.Ledger.BlockChain (HashHeader (..), LastAppliedBlock (..)) +import Shelley.Spec.Ledger.BlockChain + ( BHBody (..), + BHeader (..), + Block (..), + HashHeader (..), + LastAppliedBlock (..), + PrevHash (..), + ) import Shelley.Spec.Ledger.CompactAddr (CompactAddr (..), decompactAddr) import Shelley.Spec.Ledger.Credential ( Credential (KeyHashObj, ScriptHashObj), @@ -398,6 +406,51 @@ instance PrettyA (HashHeader c) where prettyA = ppHashHeader instance PrettyA t => PrettyA (WithOrigin t) where prettyA = ppWithOrigin prettyA +ppBHBody :: Crypto c => BHBody c -> PDoc +ppBHBody (BHBody bn sn prev vk vrfvk eta l size hash ocert protver) = + ppRecord + "BHBody" + [ ("BlockNo", ppBlockNo bn), + ("SlotNo", ppSlotNo sn), + ("Prev", ppPrevHash prev), + ("VKey", ppVKey vk), + ("VerKeyVRF", viaShow vrfvk), -- The next 3 are type families + ("Eta", viaShow eta), + ("L", viaShow l), + ("size", ppNatural size), + ("Hash", ppHash hash), + ("OCert", ppOCert ocert), + ("ProtVersion", ppProtVer protver) + ] + +ppPrevHash :: PrevHash c -> PDoc +ppPrevHash GenesisHash = ppString "GenesisHash" +ppPrevHash (BlockHash x) = ppSexp "BlockHashppHashHeader" [ppHashHeader x] + +ppBHeader :: Crypto c => BHeader c -> PDoc +ppBHeader (BHeader bh sig) = + ppRecord + "BHeader" + [ ("Body", ppBHBody bh), + ("Sig", viaShow sig) + ] + +ppBlock :: (Era era, PrettyA (Era.TxSeq era)) => Block era -> PDoc +ppBlock (Block' bh seqx _) = + ppRecord + "Block" + [ ("Header", ppBHeader bh), + ("TxSeq", prettyA seqx) + ] + +instance Crypto c => PrettyA (BHBody c) where prettyA = ppBHBody + +instance Crypto c => PrettyA (BHeader c) where prettyA = ppBHeader + +instance PrettyA (PrevHash c) where prettyA = ppPrevHash + +instance (Era era, PrettyA (Era.TxSeq era)) => PrettyA (Block era) where prettyA = ppBlock + -- ================================= -- Shelley.Spec.Ledger.LedgerState.Delegation.Certificates diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs index 87c04bfee8..16e8ccdadc 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs @@ -20,7 +20,7 @@ module Cardano.Ledger.Shelley Script, AuxiliaryData, PParams, - PParamsDelta, + Core.PParamsDelta, Tx, Witnesses, nativeMultiSigTag, @@ -52,8 +52,7 @@ import qualified Shelley.Spec.Ledger.BlockChain as Shelley txSeqTxns, ) import Shelley.Spec.Ledger.Metadata (Metadata (Metadata), validMetadatum) -import Shelley.Spec.Ledger.PParams (PParamsUpdate, updatePParams) -import qualified Shelley.Spec.Ledger.PParams as SPP (PParams) +import Shelley.Spec.Ledger.PParams (PParams, PParamsUpdate, updatePParams) import Shelley.Spec.Ledger.Scripts (MultiSig) import Shelley.Spec.Ledger.Tx ( WitnessSet, @@ -72,7 +71,6 @@ instance CryptoClass.Crypto c => UsesTxOut (ShelleyEra c) where makeTxOut _ a v = STx.TxOut a v instance CryptoClass.Crypto c => UsesPParams (ShelleyEra c) where - type PParamsDelta (ShelleyEra c) = PParamsUpdate (ShelleyEra c) mergePPUpdates _ = updatePParams -------------------------------------------------------------------------------- @@ -89,10 +87,12 @@ type instance Core.Script (ShelleyEra c) = MultiSig c type instance Core.AuxiliaryData (ShelleyEra c) = Metadata (ShelleyEra c) -type instance Core.PParams (ShelleyEra c) = SPP.PParams (ShelleyEra c) +type instance Core.PParams (ShelleyEra c) = PParams (ShelleyEra c) type instance Core.Witnesses (ShelleyEra c) = WitnessSet (ShelleyEra c) +type instance Core.PParamsDelta (ShelleyEra c) = PParamsUpdate (ShelleyEra c) + -------------------------------------------------------------------------------- -- Ledger data instances -------------------------------------------------------------------------------- @@ -141,6 +141,4 @@ type TxOut era = STx.TxOut era type TxBody era = STx.TxBody era -type PParams era = SPP.PParams era - type Witnesses era = WitnessSet (E.Crypto era) diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/Constraints.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/Constraints.hs index 3390134644..96c78c2279 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/Constraints.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/Constraints.hs @@ -15,6 +15,7 @@ import Cardano.Ledger.Core AuxiliaryData, ChainData, PParams, + PParamsDelta, Script, SerialisableData, TxBody, @@ -25,7 +26,6 @@ import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Hashes (EraIndependentTxBody) import Cardano.Ledger.SafeHash (HashAnnotated) import Cardano.Ledger.Val (DecodeMint, DecodeNonNegative, EncodeMint, Val) -import Control.DeepSeq (NFData) import Data.Kind (Constraint, Type) import Data.Proxy (Proxy) import GHC.Records (HasField) @@ -89,14 +89,11 @@ class Show (PParams era), SerialisableData (PParams era), ChainData (PParamsDelta era), - NFData (PParamsDelta era), Ord (PParamsDelta era), SerialisableData (PParamsDelta era) ) => UsesPParams era where - type PParamsDelta era :: Type - mergePPUpdates :: proxy era -> PParams era -> diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs index 9b2f622f51..ee4e09a90d 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs @@ -32,7 +32,7 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.API.Protocol (PraosCrypto) import Shelley.Spec.Ledger.BaseTypes (Globals (..), ShelleyBase) -import Shelley.Spec.Ledger.BlockChain +import Shelley.Spec.Ledger.BlockChain (BHeader, Block) import Shelley.Spec.Ledger.LedgerState (NewEpochState) import qualified Shelley.Spec.Ledger.LedgerState as LedgerState import Shelley.Spec.Ledger.PParams (PParams' (..)) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 4ea24f4961..dd782e24e3 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -113,14 +113,12 @@ import Cardano.Ledger.Coin toDeltaCoin, ) import Cardano.Ledger.Compactible +import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.SafeHash (HashAnnotated, extractHash, hashAnnotated) -import Cardano.Ledger.Shelley.Constraints - ( TransValue, - UsesPParams (PParamsDelta), - ) +import Cardano.Ledger.Shelley.Constraints (TransValue) import Cardano.Ledger.Val ((<+>), (<->), (<×>)) import qualified Cardano.Ledger.Val as Val import Control.DeepSeq (NFData) @@ -754,13 +752,16 @@ genesisState genDelegs0 utxo0 = -- | Convenience Function to bound the txsize function. -- | It can be helpful for coin selection. txsizeBound :: - forall era out. + forall era out tx. ( HasField "outputs" (Core.TxBody era) (StrictSeq out), - HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))) + HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), + HasField "body" tx (Core.TxBody era), + HasField "txsize" tx Integer ) => - Tx era -> + Proxy era -> + tx -> Integer -txsizeBound tx = numInputs * inputSize + numOutputs * outputSize + rest +txsizeBound Proxy tx = numInputs * inputSize + numOutputs * outputSize + rest where uint = 5 smallArray = 1 diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/PParams.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/PParams.hs index 82d8d4016c..89b404c497 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/PParams.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/PParams.hs @@ -39,8 +39,8 @@ import Cardano.Binary encodeWord, ) import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Core (PParamsDelta) import Cardano.Ledger.Era -import Cardano.Ledger.Shelley.Constraints (UsesPParams (PParamsDelta)) import Control.DeepSeq (NFData) import Control.Monad (unless) import Data.Aeson (FromJSON (..), ToJSON (..), (.!=), (.:), (.:?), (.=)) @@ -84,6 +84,8 @@ import Shelley.Spec.Ledger.Serialization ) import Shelley.Spec.Ledger.Slot (EpochNo (..), SlotNo (..)) +-- ==================================================================== + -- | Higher Kinded Data type family HKD f a where HKD Identity a = a diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs index 41d61a3e7e..cf61facaf9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs @@ -25,7 +25,6 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (fromTxSeq, hashTxSeq)) import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Hashes (EraIndependentBlockBody) -import Cardano.Ledger.SafeHash (SafeToHash) import Cardano.Ledger.Shelley.Constraints (UsesAuxiliary, UsesTxBody) import Control.Monad.Trans.Reader (asks) import Control.State.Transition @@ -64,7 +63,6 @@ import Shelley.Spec.Ledger.OverlaySchedule (isOverlaySlot) import Shelley.Spec.Ledger.STS.Ledgers (LedgersEnv (..)) import Shelley.Spec.Ledger.Serialization (ToCBORGroup) import Shelley.Spec.Ledger.Slot (epochInfoEpoch, epochInfoFirst) -import Shelley.Spec.Ledger.Tx (WitnessSet) import Shelley.Spec.Ledger.TxBody (EraIndependentTxBody) data BBODY era @@ -122,9 +120,7 @@ instance Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, State (Core.EraRule "LEDGERS" era) ~ LedgerState era, Signal (Core.EraRule "LEDGERS" era) ~ Seq (Era.TxInBlock era), - HasField "_d" (Core.PParams era) UnitInterval, - Core.Witnesses era ~ WitnessSet era, - SafeToHash (WitnessSet era) + HasField "_d" (Core.PParams era) UnitInterval ) => STS (BBODY era) where diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs index 6cfd8933a8..61d6671048 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs @@ -103,10 +103,7 @@ import Shelley.Spec.Ledger.LedgerState updateNES, _genDelegs, ) -import Shelley.Spec.Ledger.PParams - ( PParams, - ProtVer (..), - ) +import Shelley.Spec.Ledger.PParams (ProtVer (..)) import Shelley.Spec.Ledger.STS.Bbody (BBODY, BbodyEnv (..), BbodyPredicateFailure, BbodyState (..)) import Shelley.Spec.Ledger.STS.Prtcl ( PRTCL, @@ -187,15 +184,14 @@ instance -- | Creates a valid initial chain state initialShelleyState :: - ( Default (State (Core.EraRule "PPUP" era)), - Core.PParams era ~ PParams era + ( Default (State (Core.EraRule "PPUP" era)) ) => WithOrigin (LastAppliedBlock (Crypto era)) -> EpochNo -> UTxO era -> Coin -> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)) -> - PParams era -> + Core.PParams era -> Nonce -> ChainState era initialShelleyState lab e utxo reserves genDelegs pp initNonce = diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Newpp.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Newpp.hs index e4628628f8..812eecb000 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Newpp.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Newpp.hs @@ -19,9 +19,9 @@ module Shelley.Spec.Ledger.STS.Newpp where import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import Control.State.Transition ( STS (..), TRC (..), diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ppup.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ppup.hs index ba352cb58d..181c15ea4f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ppup.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ppup.hs @@ -25,9 +25,9 @@ import Cardano.Binary decodeWord, encodeListLen, ) +import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import Control.Monad.Trans.Reader (asks) import Control.SetAlgebra (dom, eval, (⊆), (⨃)) import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs index bf16e03a55..a1e661b13d 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs @@ -21,7 +21,7 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Shelley.Constraints ( ShelleyBased, UsesAuxiliary, - UsesPParams (PParamsDelta, mergePPUpdates), + UsesPParams (mergePPUpdates), UsesScript, UsesTxBody, UsesValue, @@ -82,7 +82,7 @@ instance HasField "_maxBHSize" (Core.PParams era) Natural, HasField "_poolDeposit" (Core.PParams era) Coin, HasField "_protocolVersion" (Core.PParams era) ProtVer, - HasField "_protocolVersion" (PParamsDelta era) (StrictMaybe ProtVer) + HasField "_protocolVersion" (Core.PParamsDelta era) (StrictMaybe ProtVer) ) => STS (UPEC era) where @@ -134,7 +134,7 @@ votedValue (ProposedPPUpdates pup) pps quorumN = votes = Map.foldr (\vote tally -> Map.insert vote (incrTally vote tally) tally) - (Map.empty :: Map (PParamsDelta era) Int) + (Map.empty :: Map (Core.PParamsDelta era) Int) pup consensus = Map.filter (>= quorumN) votes in case length consensus of diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index f43cbf8bda..d8b0ab4520 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -158,6 +158,8 @@ instance (Era era, Core.AnnotatedData (Core.Script era)) => Semigroup (WitnessSetHKD Identity era) where + (WitnessSet' a b c _) <> y | Set.null a && Map.null b && Set.null c = y + y <> (WitnessSet' a b c _) | Set.null a && Map.null b && Set.null c = y (WitnessSet a b c) <> (WitnessSet a' b' c') = WitnessSet (a <> a') (b <> b') (c <> c') @@ -219,6 +221,12 @@ instance where getField = addrWits' . getField @"wits" +instance + (c ~ Crypto era, Core.Witnesses era ~ WitnessSet era) => + HasField "addrWits" (WitnessSet era) (Set (WitVKey 'Witness c)) + where + getField = addrWits' + instance ( c ~ Crypto era, script ~ Core.Script era, @@ -228,6 +236,15 @@ instance where getField = scriptWits' . getField @"wits" +instance + ( c ~ Crypto era, + script ~ Core.Script era, + Core.Witnesses era ~ WitnessSet era + ) => + HasField "scriptWits" (WitnessSet era) (Map (ScriptHash c) script) + where + getField = scriptWits' + instance (c ~ Crypto era, Core.Witnesses era ~ WitnessSet era) => HasField "bootWits" (Tx era) (Set (BootstrapWitness c)) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs index f2735c8fce..4abe2735b6 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs @@ -101,7 +101,7 @@ import Cardano.Ledger.SafeHash SafeHash, SafeToHash, ) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta, TransValue) +import Cardano.Ledger.Shelley.Constraints (TransValue) import Cardano.Ledger.Val (DecodeNonNegative (..)) import Cardano.Prelude ( HeapWords (..), @@ -693,12 +693,12 @@ deriving instance TransTxBody NoThunks era => NoThunks (TxBodyRaw era) type TransTxBody (c :: Type -> Constraint) era = ( c (Core.TxOut era), - c (PParamsDelta era), + c (Core.PParamsDelta era), HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era) ) deriving instance - (CC.Crypto (Crypto era), NFData (PParamsDelta era)) => + (CC.Crypto (Crypto era), NFData (Core.PParamsDelta era)) => NFData (TxBodyRaw era) deriving instance (Era era, TransTxBody Eq era) => Eq (TxBodyRaw era) @@ -708,8 +708,8 @@ deriving instance (Era era, TransTxBody Show era) => Show (TxBodyRaw era) instance ( FromCBOR (Core.TxOut era), Era era, - FromCBOR (PParamsDelta era), - ToCBOR (PParamsDelta era) + FromCBOR (Core.PParamsDelta era), + ToCBOR (Core.PParamsDelta era) ) => FromCBOR (TxBodyRaw era) where @@ -723,7 +723,7 @@ instance ) instance - (TransTxBody FromCBOR era, ToCBOR (PParamsDelta era), Era era) => + (TransTxBody FromCBOR era, ToCBOR (Core.PParamsDelta era), Era era) => FromCBOR (Annotator (TxBodyRaw era)) where fromCBOR = pure <$> fromCBOR @@ -753,8 +753,8 @@ isSNothing _ = False boxBody :: ( Era era, FromCBOR (Core.TxOut era), - FromCBOR (PParamsDelta era), - ToCBOR (PParamsDelta era) + FromCBOR (Core.PParamsDelta era), + ToCBOR (Core.PParamsDelta era) ) => Word -> Field (TxBodyRaw era) @@ -772,7 +772,7 @@ boxBody n = field (\_ t -> t) (Invalid n) -- serialisation. boxBody and txSparse should be Duals, visually inspect -- The key order looks strange but was choosen for backward compatibility. txSparse :: - (TransTxBody ToCBOR era, FromCBOR (PParamsDelta era), Era era) => + (TransTxBody ToCBOR era, FromCBOR (Core.PParamsDelta era), Era era) => TxBodyRaw era -> Encode ('Closed 'Sparse) (TxBodyRaw era) txSparse (TxBodyRaw input output cert wdrl fee ttl update hash) = @@ -803,7 +803,7 @@ baseTxBodyRaw = instance ( Era era, - FromCBOR (PParamsDelta era), + FromCBOR (Core.PParamsDelta era), TransTxBody ToCBOR era ) => ToCBOR (TxBodyRaw era) @@ -821,7 +821,7 @@ deriving newtype instance (TransTxBody NoThunks era, Typeable era) => NoThunks (TxBody era) deriving newtype instance - (CC.Crypto (Crypto era), NFData (PParamsDelta era)) => + (CC.Crypto (Crypto era), NFData (Core.PParamsDelta era)) => NFData (TxBody era) deriving instance (Era era, TransTxBody Show era) => Show (TxBody era) @@ -833,14 +833,14 @@ deriving via instance ( Era era, FromCBOR (Core.TxOut era), - FromCBOR (PParamsDelta era), - ToCBOR (PParamsDelta era) + FromCBOR (Core.PParamsDelta era), + ToCBOR (Core.PParamsDelta era) ) => FromCBOR (Annotator (TxBody era)) -- | Pattern for use by external users pattern TxBody :: - (Era era, FromCBOR (PParamsDelta era), TransTxBody ToCBOR era) => + (Era era, FromCBOR (Core.PParamsDelta era), TransTxBody ToCBOR era) => Set (TxIn (Crypto era)) -> StrictSeq (Core.TxOut era) -> StrictSeq (DCert (Crypto era)) -> diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs index 64bb3eb6f3..a19e78728b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs @@ -65,11 +65,13 @@ import Shelley.Spec.Ledger.STS.Prtcl (PrtclState (..)) import Shelley.Spec.Ledger.STS.Tickn (TicknState (..)) import Shelley.Spec.Ledger.TxBody (TransTxBody, TransTxId) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv, PreAlonzo) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen) import Test.Shelley.Spec.Ledger.Generator.Presets (genEnv) import Test.Shelley.Spec.Ledger.Serialisation.Generators () -import Test.Shelley.Spec.Ledger.Utils (ShelleyLedgerSTS, ShelleyTest, testGlobals) +import Test.Shelley.Spec.Ledger.Utils (ShelleyTest, testGlobals) -- Use Another constraint, so this works in all Eras +import Test.Shelley.Spec.Ledger.Generator.EraGen(MinLEDGER_STS) + data ValidateInput era = ValidateInput Globals (NewEpochState era) (Block era) @@ -82,13 +84,12 @@ instance NFData (ValidateInput era) where validateInput :: ( EraGen era, ShelleyTest era, - PreAlonzo era, Mock (Crypto era), Core.EraRule "LEDGERS" era ~ API.LEDGERS era, QC.HasTrace (API.LEDGERS era) (GenEnv era), API.ApplyBlock era, API.GetLedgerView era, - ShelleyLedgerSTS era + MinLEDGER_STS era ) => Int -> IO (ValidateInput era) @@ -97,13 +98,12 @@ validateInput utxoSize = genValidateInput utxoSize genValidateInput :: ( EraGen era, ShelleyTest era, - PreAlonzo era, Mock (Crypto era), Core.EraRule "LEDGERS" era ~ API.LEDGERS era, QC.HasTrace (API.LEDGERS era) (GenEnv era), API.ApplyBlock era, API.GetLedgerView era, - ShelleyLedgerSTS era + MinLEDGER_STS era ) => Int -> IO (ValidateInput era) @@ -185,8 +185,7 @@ genUpdateInputs :: ( EraGen era, Mock (Crypto era), ShelleyTest era, - PreAlonzo era, - ShelleyLedgerSTS era, + MinLEDGER_STS era, API.GetLedgerView era, Core.EraRule "LEDGERS" era ~ API.LEDGERS era, QC.HasTrace (API.LEDGERS era) (GenEnv era), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs index ad2ac74625..31db7f4e7e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs @@ -47,14 +47,15 @@ import Test.Shelley.Spec.Ledger.Generator.Constants minGenesisUTxOouts ), ) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..),PreAlonzo) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..)) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen) import Test.Shelley.Spec.Ledger.Generator.Presets (genEnv) import Test.Shelley.Spec.Ledger.Generator.Trace.Chain (mkGenesisChainState) import Test.Shelley.Spec.Ledger.Generator.Trace.DCert (CERTS) import Test.Shelley.Spec.Ledger.Generator.Utxo (genTx) import Test.Shelley.Spec.Ledger.Serialisation.Generators () -import Test.Shelley.Spec.Ledger.Utils (ShelleyLedgerSTS, ShelleyTest) +import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) -- Use Another constraint, so this works in all Eras +import Test.Shelley.Spec.Ledger.Generator.EraGen(MinLEDGER_STS) -- =============================================================== @@ -85,9 +86,9 @@ genChainState n ge = -- | Benchmark generating a block given a chain state. genBlock :: ( Mock (Crypto era), - PreAlonzo era, ShelleyTest era, - ShelleyLedgerSTS era, + EraGen era, + MinLEDGER_STS era, GetLedgerView era, Core.EraRule "LEDGERS" era ~ LEDGERS era, QC.HasTrace (LEDGERS era) (GenEnv era), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs index e6f087de07..a952d92dc2 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs @@ -6,11 +6,13 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Test.Shelley.Spec.Ledger.Generator.Block ( genBlock, genBlockWithTxGen, tickChainState, + TxInBlock, ) where @@ -51,57 +53,61 @@ import Test.Shelley.Spec.Ledger.Generator.Core getKESPeriodRenewalNo, mkBlock, mkOCert, - PreAlonzo, ) import Test.Shelley.Spec.Ledger.Generator.Trace.Ledger () import Test.Shelley.Spec.Ledger.Utils - ( ShelleyLedgerSTS, - ShelleyTest, - epochFromSlotNo, + ( epochFromSlotNo, maxKESIterations, runShelleyBase, slotFromEpoch, testGlobals, ) +import Cardano.Ledger.Era(SupportsSegWit(TxSeq,TxInBlock)) +import Test.Shelley.Spec.Ledger.Generator.EraGen(EraGen(..), MinLEDGER_STS) +import Shelley.Spec.Ledger.BaseTypes(UnitInterval) +import GHC.Records(HasField(getField)) +import Shelley.Spec.Ledger.Serialization(ToCBORGroup) +import qualified Cardano.Ledger.Era as Era(TxInBlock) + -- ====================================================== -- | Type alias for a transaction generator type TxGen era = - PParams era -> + Core.PParams era -> AccountState -> LedgerState era -> SlotNo -> - Gen (Seq (Tx era)) + Gen (Seq (Era.TxInBlock era)) -- | Generate a valid block. genBlock :: forall era. - ( ShelleyTest era, - PreAlonzo era, + ( MinLEDGER_STS era, + ToCBORGroup (TxSeq era), ApplyBlock era, Mock (Crypto era), GetLedgerView era, - ShelleyLedgerSTS era, - QC.HasTrace (Core.EraRule "LEDGERS" era) (GenEnv era) + QC.HasTrace (Core.EraRule "LEDGERS" era) (GenEnv era), + EraGen era ) => GenEnv era -> ChainState era -> Gen (Block era) genBlock ge = genBlockWithTxGen genTxs ge where + genTxs :: TxGen era genTxs pp reserves ls s = do - let ledgerEnv = LedgersEnv s pp reserves - + let ledgerEnv = LedgersEnv @era s pp reserves sigGen @(Core.EraRule "LEDGERS" era) ge ledgerEnv ls genBlockWithTxGen :: forall era. - ( ShelleyTest era, + ( ToCBORGroup (TxSeq era), Mock (Crypto era), - PreAlonzo era, GetLedgerView era, - ApplyBlock era + ApplyBlock era, + EraGen era ) => TxGen era -> GenEnv era -> @@ -167,7 +173,7 @@ genBlockWithTxGen selectNextSlotWithLeader :: forall era. ( Mock (Crypto era), - ShelleyTest era, + EraGen era, GetLedgerView era, ApplyBlock era ) => @@ -182,7 +188,8 @@ selectNextSlotWithLeader startSlot = List.find (const True) . catMaybes $ selectNextSlotWithLeaderThisEpoch - <$> (startSlot : [slotFromEpoch x | x <- [startEpoch + 1 ..]]) + <$> (startSlot : [slotFromEpoch x | x <- [startEpoch + 1 .. startEpoch + 4]]) + -- If we can't find a leader in the next N Epochs, some thing is wrong, N=4 should be large enough. where startEpoch = epochFromSlotNo startSlot selectNextSlotWithLeaderThisEpoch :: @@ -227,7 +234,9 @@ selectNextSlotWithLeader (GenDelegs cores) = (_genDelegs . _dstate) dpstate firstEpochSlot = slotFromEpoch (epochFromSlotNo slotNo) f = activeSlotCoeff testGlobals - d = (_d . esPp . nesEs . chainNes) chainSt + getUnitInterval :: Core.PParams era -> UnitInterval + getUnitInterval pp = getField @"_d" pp + d = (getUnitInterval . esPp . nesEs . chainNes) chainSt isLeader poolHash vrfKey = let y = VRF.evalCertified @(VRF (Crypto era)) () (mkSeed seedL slotNo epochNonce) vrfKey diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs index 009ebdeed1..8538fafbee 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs @@ -58,8 +58,7 @@ import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (DSIGN) import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Crypto (..)) -import qualified Cardano.Ledger.Era as Era +import Cardano.Ledger.Era (Crypto (..),TxInBlock) import Cardano.Ledger.Hashes (EraIndependentBlockBody) import Cardano.Ledger.Shelley.Constraints ( UsesTxBody, @@ -93,9 +92,7 @@ import Shelley.Spec.Ledger.BlockChain ( BHeader (BHeader), Block (Block), HashHeader, - TxSeq (..), bBodySize, - bbHash, mkSeed, seedEta, seedL, @@ -163,8 +160,7 @@ import Shelley.Spec.Ledger.Slot (*-), ) import Shelley.Spec.Ledger.Tx - ( Tx, - TxIn, + ( TxIn, WitnessSet, pattern TxIn, ) @@ -194,7 +190,6 @@ import Test.Shelley.Spec.Ledger.Generator.ScriptClass import Test.Shelley.Spec.Ledger.Orphans () import Test.Shelley.Spec.Ledger.Utils ( GenesisKeyPair, - ShelleyTest, epochFromSlotNo, evolveKESUntil, maxKESIterations, @@ -206,13 +201,16 @@ import Test.Shelley.Spec.Ledger.Utils unsafeMkUnitInterval, ) --- ================================================== +import Shelley.Spec.Ledger.Serialization(ToCBORGroup) +import Cardano.Ledger.Era(SupportsSegWit(toTxSeq,hashTxSeq)) +import qualified Cardano.Ledger.Era as Era(TxSeq) + + +-- | For use in the Serialisation and Example Tests, which assume Shelley, Allegra, or Mary Eras. type PreAlonzo era = ( Core.Witnesses era ~ WitnessSet era, - Core.Tx era ~ Tx era, - ToCBOR (Core.AuxiliaryData era), - Era.TxSeq era ~ TxSeq era + ToCBOR (Core.AuxiliaryData era) ) -- ========================================= @@ -530,7 +528,7 @@ mkBlockHeader prev pkeys s blockNo enonce kesPeriod c0 oCert bodySize bodyHash = mkBlock :: forall era r. ( UsesTxBody era, - PreAlonzo era, + ToCBORGroup (Era.TxSeq era), Mock (Crypto era) ) => -- | Hash of previous block @@ -538,7 +536,7 @@ mkBlock :: -- | All keys in the stake pool AllIssuerKeys (Crypto era) r -> -- | Transactions to record - [Tx era] -> + [TxInBlock era] -> -- | Current slot SlotNo -> -- | Block number/chain length/chain "difficulty" @@ -553,16 +551,17 @@ mkBlock :: OCert (Crypto era) -> Block era mkBlock prev pkeys txns s blockNo enonce kesPeriod c0 oCert = - let bodySize = fromIntegral $ bBodySize $ (TxSeq @era . StrictSeq.fromList) txns - bodyHash = bbHash $ TxSeq @era $ StrictSeq.fromList txns + let txseq = (toTxSeq @era . StrictSeq.fromList) txns + bodySize = fromIntegral $ bBodySize $ txseq + bodyHash = hashTxSeq @era txseq bh = mkBlockHeader prev pkeys s blockNo enonce kesPeriod c0 oCert bodySize bodyHash - in Block bh (TxSeq @era $ StrictSeq.fromList txns) + in Block bh txseq -- | Create a block with a faked VRF result. mkBlockFakeVRF :: forall era r. ( UsesTxBody era, - PreAlonzo era, + ToCBORGroup (Era.TxSeq era), ExMock (Crypto era) ) => -- | Hash of previous block @@ -570,7 +569,7 @@ mkBlockFakeVRF :: -- | All keys in the stake pool AllIssuerKeys (Crypto era) r -> -- | Transactions to record - [Tx era] -> + [TxInBlock era] -> -- | Current slot SlotNo -> -- | Block number/chain length/chain "difficulty" @@ -593,6 +592,7 @@ mkBlockFakeVRF prev pkeys txns s blockNo enonce (NatNonce bnonce) l kesPeriod c0 KeyPair vKeyCold _ = cold pkeys nonceNonce = mkSeed seedEta s enonce leaderNonce = mkSeed seedL s enonce + txseq = toTxSeq @era (StrictSeq.fromList txns) bhb = BHBody blockNo @@ -608,8 +608,8 @@ mkBlockFakeVRF prev pkeys txns s blockNo enonce (NatNonce bnonce) l kesPeriod c0 (WithResult leaderNonce (fromIntegral $ unitIntervalToNatural l)) (fst $ vrf pkeys) ) - (fromIntegral $ bBodySize $ (TxSeq @era . StrictSeq.fromList) txns) - (bbHash $ TxSeq @era $ StrictSeq.fromList txns) + (fromIntegral $ bBodySize $ txseq) + (hashTxSeq @era txseq) oCert (ProtVer 0 0) kpDiff = kesPeriod - c0 @@ -619,7 +619,7 @@ mkBlockFakeVRF prev pkeys txns s blockNo enonce (NatNonce bnonce) l kesPeriod c0 Just hkey -> hkey sig = signedKES () kpDiff bhb hotKey bh = BHeader bhb sig - in Block bh (TxSeq @era $ StrictSeq.fromList txns) + in Block bh txseq -- | We provide our own nonces to 'mkBlock', which we then wish to recover as -- the output of the VRF functions. In general, however, we just derive them @@ -689,7 +689,8 @@ genesisCoins genesisTxId outs = -- | Apply a transaction body as a state transition function on the ledger state. applyTxBody :: forall era. - ( ShelleyTest era, + ( Era era, + Show (Core.TxOut era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Delegation.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Delegation.hs index 329e929426..bd784aeb70 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Delegation.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Delegation.hs @@ -34,7 +34,6 @@ import Data.Ratio ((%)) import qualified Data.Sequence.Strict as StrictSeq import Data.Set ((\\)) import qualified Data.Set as Set -import GHC.Stack (HasCallStack) import Numeric.Natural (Natural) import Shelley.Spec.Ledger.API ( AccountState (..), @@ -56,8 +55,6 @@ import Shelley.Spec.Ledger.API MIRPot (..), MIRTarget (..), Network (..), - PParams, - PParams' (..), PState (..), PoolCert (..), PoolParams (..), @@ -89,6 +86,11 @@ import Test.Shelley.Spec.Ledger.Generator.Core ) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) import Test.Shelley.Spec.Ledger.Utils +import GHC.Records(HasField(..)) +import Shelley.Spec.Ledger.BaseTypes(UnitInterval) +import Shelley.Spec.Ledger.PParams(ProtVer) + +-- ====================================================== data CertCred era = CoreKeyCred [GenesisKeyPair (Crypto era)] @@ -110,11 +112,10 @@ deriving instance (Era era, Show (Core.Script era)) => Show (CertCred era) -- -- Note: we register keys and pools more often than deregistering/retiring them, -- and we generate more delegations than registrations of keys/pools. -genDCert :: - (HasCallStack, Era era, EraGen era) => +genDCert :: forall era. EraGen era => Constants -> KeySpace era -> - PParams era -> + Core.PParams era -> AccountState -> DPState (Crypto era) -> SlotNo -> @@ -144,7 +145,7 @@ genDCert slot = QC.frequency [ (frequencyRegKeyCert, genRegKeyCert c ksKeyPairs ksMSigScripts dState), - (frequencyRegPoolCert, genRegPool ksStakePools ksKeyPairs (_minPoolCost pparams)), + (frequencyRegPoolCert, genRegPool ksStakePools ksKeyPairs (getField @"_minPoolCost" pparams)), (frequencyDelegationCert, genDelegation c ksKeyPairs ksMSigScripts dpState), ( frequencyGenesisDelegationCert, genGenesisDelegation ksCoreNodes ksGenesisDelegates dpState @@ -165,9 +166,7 @@ genDCert pState = _pstate dpState -- | Generate a RegKey certificate -genRegKeyCert :: - forall era. - (HasCallStack, Era era, EraGen era) => +genRegKeyCert :: forall era. ValidateScript era => Constants -> KeyPairs (Crypto era) -> [(Core.Script era, Core.Script era)] -> @@ -211,8 +210,7 @@ genRegKeyCert -- | Generate a DeRegKey certificate along with the staking credential, which is -- needed to witness the certificate. genDeRegKeyCert :: - forall era. - (HasCallStack, Era era, EraGen era) => + forall era. ValidateScript era => Constants -> KeyPairs (Crypto era) -> [(Core.Script era, Core.Script era)] -> @@ -265,9 +263,7 @@ genDeRegKeyCert Constants {frequencyKeyCredDeReg, frequencyScriptCredDeReg} keys -- -- Returns nothing if there are no registered staking credentials or no -- registered pools. -genDelegation :: - forall era. - (HasCallStack, Era era, EraGen era) => +genDelegation :: forall era. ValidateScript era => Constants -> KeyPairs (Crypto era) -> [(Core.Script era, Core.Script era)] -> @@ -315,7 +311,7 @@ genDelegation availablePools = Set.toList $ domain registeredPools genGenesisDelegation :: - (HasCallStack, Era era) => + (Era era) => -- | Core nodes [(GenesisKeyPair (Crypto era), AllIssuerKeys (Crypto era) 'GenesisDelegate)] -> -- | All potential genesis delegate keys @@ -356,7 +352,7 @@ genGenesisDelegation coreNodes delegateKeys dpState = -- | Generate PoolParams and the key witness. genStakePool :: forall crypto. - (HasCallStack, CC.Crypto crypto) => + (CC.Crypto crypto) => -- | Available keys for stake pool registration [AllIssuerKeys crypto 'StakePool] -> -- | KeyPairs containing staking keys to act as owners/reward account @@ -396,7 +392,7 @@ genStakePool poolKeys skeys (Coin minPoolCost) = -- | Generate `RegPool` and the key witness. genRegPool :: - (HasCallStack, Era era) => + (Era era) => [AllIssuerKeys (Crypto era) 'StakePool] -> KeyPairs (Crypto era) -> Coin -> @@ -413,8 +409,8 @@ genRegPool poolKeys keyPairs minPoolCost = do -- constructed value, return the keypair which corresponds to the selected -- `KeyHash`, by doing a lookup in the set of `availableKeys`. genRetirePool :: - HasCallStack => - PParams era -> + HasField "_eMax" (Core.PParams era) EpochNo => + Core.PParams era -> [AllIssuerKeys (Crypto era) 'StakePool] -> PState (Crypto era) -> SlotNo -> @@ -442,16 +438,16 @@ genRetirePool pp poolKeys pState slot = (List.find (\x -> hk x == hk') poolKeys) EpochNo cepoch = epochFromSlotNo slot epochLow = cepoch + 1 - EpochNo retirementBound = _eMax pp + EpochNo retirementBound = getField @"_eMax" pp epochHigh = cepoch + retirementBound - 1 -- | Generate an InstantaneousRewards Transfer certificate genInstantaneousRewardsAccounts :: - (HasCallStack, Era era) => + (Era era, HasField "_d" (Core.PParams era) UnitInterval) => SlotNo -> -- | Index over the cold key hashes of all possible Genesis Delegates Map (KeyHash 'GenesisDelegate (Crypto era)) (AllIssuerKeys (Crypto era) 'GenesisDelegate) -> - PParams era -> + Core.PParams era -> AccountState -> DState (Crypto era) -> Gen (Maybe (DCert (Crypto era), CertCred era)) @@ -480,7 +476,7 @@ genInstantaneousRewardsAccounts s genesisDelegatesByHash pparams accountState de pure $ if -- Discard this generator (by returning Nothing) if: -- we are in full decentralisation mode (d=0) when IR certs are not allowed - _d pparams == interval0 + getField @"_d" pparams == interval0 -- or when we don't have keys available for generating an IR cert || null credCoinMap -- or it's too late in the epoch for IR certs @@ -496,11 +492,11 @@ genInstantaneousRewardsAccounts s genesisDelegatesByHash pparams accountState de -- | Generate an InstantaneousRewards Transfer genInstantaneousRewardsTransfer :: - (HasCallStack, Era era) => + (HasField "_d" (Core.PParams era) UnitInterval, Era era) => SlotNo -> -- | Index over the cold key hashes of all possible Genesis Delegates Map (KeyHash 'GenesisDelegate (Crypto era)) (AllIssuerKeys (Crypto era) 'GenesisDelegate) -> - PParams era -> + Core.PParams era -> AccountState -> DState (Crypto era) -> Gen (Maybe (DCert (Crypto era), CertCred era)) @@ -521,7 +517,7 @@ genInstantaneousRewardsTransfer s genesisDelegatesByHash pparams accountState de pure $ if -- Discard this generator (by returning Nothing) if: -- we are in full decentralisation mode (d=0) when IR certs are not allowed - _d pparams == interval0 + getField @"_d" pparams == interval0 -- or it's too late in the epoch for IR certs || tooLateInEpoch s then Nothing @@ -532,11 +528,14 @@ genInstantaneousRewardsTransfer s genesisDelegatesByHash pparams accountState de ) genInstantaneousRewards :: - (HasCallStack, Era era) => + ( Era era, + HasField "_protocolVersion" (Core.PParams era) ProtVer, + HasField "_d" (Core.PParams era) UnitInterval + ) => SlotNo -> -- | Index over the cold key hashes of all possible Genesis Delegates Map (KeyHash 'GenesisDelegate (Crypto era)) (AllIssuerKeys (Crypto era) 'GenesisDelegate) -> - PParams era -> + Core.PParams era -> AccountState -> DState (Crypto era) -> Gen (Maybe (DCert (Crypto era), CertCred era)) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs index 4dcc502f8d..d62c42172e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs @@ -7,55 +7,206 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -module Test.Shelley.Spec.Ledger.Generator.EraGen (genUtxo0, genesisId, EraGen (..)) where +-- | Infrastructure for generating STS Traces over any Era +module Test.Shelley.Spec.Ledger.Generator.EraGen + ( genUtxo0, + genesisId, + EraGen (..), + MinLEDGER_STS, + MinCHAIN_STS, + MinUTXO_STS, + MinGenTxBody, + MinGenTxout(..), + Label(..), + Sets(..), + ) where -import Cardano.Binary (ToCBOR (toCBOR)) +import Cardano.Binary (ToCBOR (toCBOR),FromCBOR,Annotator) import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (HASH) -import Cardano.Ledger.Era (Crypto, ValidateScript (..)) +import Cardano.Ledger.Era (Crypto, ValidateScript (..),TxInBlock) import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) -import Cardano.Ledger.Shelley.Constraints (UsesScript, UsesTxOut) +import Cardano.Ledger.Shelley.Constraints (UsesPParams(..)) +import Shelley.Spec.Ledger.PParams(Update) import Cardano.Slotting.Slot (SlotNo) import Data.Coerce (coerce) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) +import Data.Default.Class(Default) import Shelley.Spec.Ledger.API ( Addr (Addr), Credential (ScriptHashObj), StakeReference (StakeRefBase), + Block(..), ) import Shelley.Spec.Ledger.Address (toAddr) -import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe) -import Shelley.Spec.Ledger.PParams (PParams, Update) +import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe,ShelleyBase) import Shelley.Spec.Ledger.Tx (TxId (TxId)) -import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl) +import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl, WitVKey) import Shelley.Spec.Ledger.UTxO (UTxO) +import Shelley.Spec.Ledger.Keys(KeyRole(Witness)) import Test.QuickCheck (Gen) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Shelley.Spec.Ledger.Generator.Core ( GenEnv (..), - genTxOut, genesisCoins, ) import Test.Shelley.Spec.Ledger.Generator.Presets (someKeyPairs) import Test.Shelley.Spec.Ledger.Generator.ScriptClass (ScriptClass, someScripts) import Test.Shelley.Spec.Ledger.Utils (Split (..)) +import Data.Sequence (Seq) +import Shelley.Spec.Ledger.API + ( DPState, + LedgerEnv, + LedgerState, + LedgersEnv, + ) +import Shelley.Spec.Ledger.LedgerState (UTxOState (..)) +import Shelley.Spec.Ledger.STS.Chain(CHAIN,ChainState) +import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv) +import Control.State.Transition.Extended(STS(..)) + +import GHC.Records(HasField(..)) +import Shelley.Spec.Ledger.BaseTypes(UnitInterval) +import Shelley.Spec.Ledger.PParams(ProtVer) +import Shelley.Spec.Ledger.Slot (EpochNo) +import Shelley.Spec.Ledger.Scripts (ScriptHash) +import Cardano.Ledger.Era (Era) +import GHC.Natural(Natural) +import Cardano.Ledger.AuxiliaryData(ValidateAuxiliaryData(..)) +import NoThunks.Class(NoThunks) +import Data.Map(Map) + {------------------------------------------------------------------------------ - An EraGen instance makes it possible to run the Shelley property tests + An EraGen instance makes it possible to run the Shelley property tests. The idea + is to generate (not fully) random Transactions, i.e. with enough coherency to be + a real transaction, but which are strung together into Traces. In each step of the trace + one of these (not fully) random transactions is applied. The idea is that some property should + hold on any trace. Because we want these tests to work in any Era there are two things + to consider: + 1) A Transaction generator needs to be parametric over all Eras. + 2) Since the Internals of the STS rules differ from Era to Era, the STS instances + must also adapt to many Eras. + + To account for the "not fully" random nature of tranactions we use the type GenEnv which + holds enough information to build "not fully" random transactions that are still coherent. + + For Transactions, we account for these differences by using the type families found in + Cardano.Ledger.Core and other modules, and by a set of Era specific generators encoded + in the EraGen class. Generally there is some "method" in the class for each type family. + + For traces we use the "class HasTrace (CHAIN era) (GenEnv era)" + + The following constraints encode the minimal properties needed to build a chain for + any Era. It should be an invariant that these properties hold for all Eras (Shelley, Allegra, Mary, Alonzo ...) + If we introduce a new Era, where they do not hold, we must adjust these things, so they do. + 1) Add a new type family + 2) Add new methods to EraGen + 3) Change the minimal constraints, so that they now hold for all Eras + 4) Change the generators to use the new methods. + -----------------------------------------------------------------------------} +-- | Minimal requirements on the LEDGER and LEDGERS instances +type MinLEDGER_STS era = + ( Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, + BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase, + Signal (Core.EraRule "LEDGER" era) ~ TxInBlock era, + State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), + Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, + BaseM (Core.EraRule "LEDGERS" era) ~ ShelleyBase, + State (Core.EraRule "LEDGERS" era) ~ LedgerState era, + Signal (Core.EraRule "LEDGERS" era) ~ Seq (TxInBlock era), + STS (Core.EraRule "LEDGER" era) + ) + +-- | Minimal requirements on the CHAIN instances +type MinCHAIN_STS era = + ( STS (CHAIN era), + BaseM (CHAIN era) ~ ShelleyBase, + Environment (CHAIN era) ~ (), + State (CHAIN era) ~ ChainState era, + Signal (CHAIN era) ~ Block era + ) + +-- | Minimal requirements on the UTxO instances +type MinUTXO_STS era = + ( STS (Core.EraRule "UTXOW" era), + BaseM (Core.EraRule "UTXOW" era) ~ ShelleyBase, + State (Core.EraRule "UTXOW" era) ~ UTxOState era, + Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + State (Core.EraRule "UTXO" era) ~ UTxOState era, + Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, + Signal (Core.EraRule "UTXO" era) ~ TxInBlock era + ) + +-- | Minimal requirements on Core.PParams to generate random stuff +type MinGenPParams era = + ( UsesPParams era, + Default (Core.PParams era), + HasField "_minPoolCost" (Core.PParams era) Coin, + HasField "_protocolVersion" (Core.PParams era) ProtVer, + HasField "_eMax" (Core.PParams era) EpochNo, + HasField "_d" (Core.PParams era) UnitInterval, + HasField "_keyDeposit" (Core.PParams era) Coin, + HasField "_poolDeposit" (Core.PParams era) Coin, + HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minUTxOValue" (Core.PParams era) Coin, + HasField "_minfeeB" (Core.PParams era) Natural + ) + +type MinGenWitnesses era = + ( ToCBOR (Core.Witnesses era), + Eq (Core.Witnesses era), + Monoid (Core.Witnesses era) + ) + +type MinGenAuxData era = + ( ValidateAuxiliaryData era (Crypto era), + ToCBOR (Core.AuxiliaryData era), -- Needs to be serialized + Eq (Core.AuxiliaryData era), + Show (Core.AuxiliaryData era), + FromCBOR(Annotator (Core.AuxiliaryData era)) -- arises because some pattern Constructors deserialize + ) + +type MinGenTxBody era = + ( Eq (Core.TxBody era), + ToCBOR (Core.TxBody era), + NoThunks (Core.TxBody era), + Show (Core.TxBody era), + FromCBOR(Annotator (Core.TxBody era)) -- arises because some pattern Constructors deserialize + ) + +class MinGenTxout era where + calcEraMinUTxO :: Core.TxOut era -> Core.PParams era -> Coin + addValToTxOut :: Core.Value era -> Core.TxOut era -> Core.TxOut era + genEraTxOut :: Gen (Core.Value era) -> [Addr (Crypto era)] -> Gen [Core.TxOut era] + +-- ====================================================================================== +-- The EraGen class. Generally one method for each type family in Cardano.Ledger.Core +-- ====================================================================================== + class - ( UsesScript era, - ValidateScript era, + ( Era era, Split (Core.Value era), ScriptClass era, - Show (Core.Script era) + MinGenPParams era, + MinGenWitnesses era, + MinGenAuxData era, + MinGenTxBody era, + MinGenTxout era ) => EraGen era where @@ -67,7 +218,7 @@ class -- additional script witnessing. genEraTxBody :: GenEnv era -> - PParams era -> + Core.PParams era -> SlotNo -> Set (TxIn (Crypto era)) -> StrictSeq (Core.TxOut era) -> @@ -89,20 +240,32 @@ class StrictSeq (Core.TxOut era) -> Core.TxBody era + genEraPParamsDelta :: Constants -> Core.PParams era -> Gen (Core.PParamsDelta era) + + genEraPParams :: Constants -> Gen (Core.PParams era) + -- Its is VERY IMPORTANT that the decentralisation parameter "_d" be non-zero and less than 1. + -- The system will deadlock if d==0 and there are no registered stake pools. + -- use Test.Shelley.Spec.Ledger.Generator.Update(genDecentralisationParam) in your instance. + + genEraWitnesses :: + (Set (WitVKey 'Witness (Crypto era))) -> + Map (ScriptHash (Crypto era)) (Core.Script era) -> + Core.Witnesses era + + unsafeApplyTx :: Core.Tx era -> TxInBlock era + + + {------------------------------------------------------------------------------ Generators shared across eras -----------------------------------------------------------------------------} -genUtxo0 :: - forall era. - (EraGen era, UsesTxOut era) => - GenEnv era -> - Gen (UTxO era) +genUtxo0 :: forall era. EraGen era => GenEnv era -> Gen (UTxO era) genUtxo0 ge@(GenEnv _ c@Constants {minGenesisUTxOouts, maxGenesisUTxOouts}) = do genesisKeys <- someKeyPairs c minGenesisUTxOouts maxGenesisUTxOouts genesisScripts <- someScripts @era c minGenesisUTxOouts maxGenesisUTxOouts outs <- - (genTxOut @era) + (genEraTxOut @era) (genGenesisValue @era ge) (fmap (toAddr Testnet) genesisKeys ++ fmap (scriptsToAddr' Testnet) genesisScripts) return (genesisCoins genesisId outs) @@ -122,3 +285,14 @@ genesisId = TxId (unsafeMakeSafeHash (mkDummyHash 0)) where mkDummyHash :: forall h a. Hash.HashAlgorithm h => Int -> Hash.Hash h a mkDummyHash = coerce . Hash.hashWithSerialiser @h toCBOR + + +-- ========================================================= + + +data Label t where + Body' :: Label (Core.TxBody era) + Wits' :: Label (Core.Witnesses era) + +class Sets (x :: Label t) y where + set :: Label t -> y -> y \ No newline at end of file diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ScriptClass.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ScriptClass.hs index dd9e037f1f..39d913817b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ScriptClass.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ScriptClass.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveFunctor #-} module Test.Shelley.Spec.Ledger.Generator.ScriptClass ( ScriptClass (..), @@ -33,6 +34,7 @@ module Test.Shelley.Spec.Ledger.Generator.ScriptClass mkScriptCombinations, combinedScripts, someScripts, + baseScripts, scriptKeyCombinations, scriptKeyCombination, ) @@ -59,6 +61,7 @@ import Test.Shelley.Spec.Ledger.Generator.Constants ( Constants (..), ) import Test.Shelley.Spec.Ledger.Utils (mkKeyPair) +import Cardano.Ledger.Shelley.Constraints (UsesScript) {------------------------------------------------------------------------------ ScriptClass defines the operations that enable an Era's scripts to @@ -66,10 +69,9 @@ import Test.Shelley.Spec.Ledger.Utils (mkKeyPair) ------------------------------------------------------------------------------} class - ( Eq (Script era), + ( UsesScript era, ValidateScript era, - CC.Crypto (Crypto era), - Era era + CC.Crypto (Crypto era) ) => ScriptClass era where @@ -84,6 +86,7 @@ class -----------------------------------------------------------------------------} data Quantifier t = AllOf [t] | AnyOf [t] | MOf Int [t] | Leaf t + deriving Functor anyOf :: forall era. ScriptClass era => Proxy era -> [Script era] -> Script era anyOf prox xs = unQuantify prox $ AnyOf xs @@ -94,6 +97,8 @@ allOf prox xs = unQuantify prox $ AllOf xs mOf :: forall era. ScriptClass era => Proxy era -> Int -> [Script era] -> Script era mOf prox m xs = unQuantify prox $ MOf m xs + + {------------------------------------------------------------------------------ Compute lists of keyHashes ------------------------------------------------------------------------------} diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs index ddc17fb966..7482b3c903 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs @@ -27,13 +27,14 @@ import Shelley.Spec.Ledger.API Update, ) import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) -import Shelley.Spec.Ledger.PParams (PParams) +import Shelley.Spec.Ledger.PParams (PParams,PParams'(..)) import Shelley.Spec.Ledger.STS.EraMapping () import Shelley.Spec.Ledger.Scripts (MultiSig (..)) import Shelley.Spec.Ledger.Slot (SlotNo (..)) import Shelley.Spec.Ledger.Tx ( TxIn (..), TxOut (..), + pattern WitnessSet, ) import Shelley.Spec.Ledger.TxBody (TxBody (TxBody, _inputs, _outputs, _txfee), Wdrl (..)) import Test.QuickCheck (Gen) @@ -43,7 +44,8 @@ import Test.Shelley.Spec.Ledger.Generator.Core genCoin, genNatural, ) -import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..),MinGenTxout(..)) import Test.Shelley.Spec.Ledger.Generator.Metadata (genMetadata) import Test.Shelley.Spec.Ledger.Generator.ScriptClass ( Quantifier (..), @@ -51,6 +53,10 @@ import Test.Shelley.Spec.Ledger.Generator.ScriptClass ) import Test.Shelley.Spec.Ledger.Generator.Trace.Chain () import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) +import Test.Shelley.Spec.Ledger.Generator.Update(genShelleyPParamsDelta) +import Test.Shelley.Spec.Ledger.Generator.Update (genPParams) +import Cardano.Ledger.Val((<+>)) +import Control.Monad (replicateM) {------------------------------------------------------------------------------ ShelleyEra instances for EraGen and ScriptClass @@ -78,6 +84,12 @@ instance _inputs = ins, _outputs = outs } + genEraPParamsDelta = genShelleyPParamsDelta + genEraPParams = genPParams + + genEraWitnesses setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty + unsafeApplyTx x = x + instance CC.Crypto c => ScriptClass (ShelleyEra c) where basescript _proxy = RequireSignature @@ -127,3 +139,12 @@ genTimeToLive :: SlotNo -> Gen SlotNo genTimeToLive currentSlot = do ttl <- genNatural 50 100 pure $ currentSlot + SlotNo (fromIntegral ttl) + + +instance Mock c => MinGenTxout (ShelleyEra c) where + calcEraMinUTxO _txout pp = (_minUTxOValue pp) + addValToTxOut v (TxOut a u) = TxOut a (v <+> u) + genEraTxOut genVal addrs = do + values <- replicateM (length addrs) genVal + let makeTxOut (addr,val) = TxOut addr val + pure (makeTxOut <$> zip addrs values) \ No newline at end of file diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs index f0f095e28e..46cd313d37 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs @@ -36,10 +36,10 @@ import Control.State.Transition.Trace.Generator.QuickCheck HasTrace, envGen, interpretSTS, - shrinkSignal, sigGen, ) import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC +import Data.Default.Class(Default) import Data.Functor.Identity (runIdentity) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -62,39 +62,41 @@ import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes ( Mock, ) import Test.Shelley.Spec.Ledger.Generator.Block (genBlock) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..),PreAlonzo) -import Test.Shelley.Spec.Ledger.Generator.EraGen - ( EraGen (..), - genUtxo0, - ) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..)) + import Test.Shelley.Spec.Ledger.Generator.Presets (genesisDelegs0) -import Test.Shelley.Spec.Ledger.Generator.Update (genPParams) -import Test.Shelley.Spec.Ledger.Shrinkers (shrinkBlock) +-- import Test.Shelley.Spec.Ledger.Shrinkers (shrinkBlock) -- TODO FIX ME import Test.Shelley.Spec.Ledger.Utils - ( ShelleyChainSTS, - ShelleyLedgerSTS, - ShelleyTest, - maxLLSupply, + ( maxLLSupply, mkHash, ) +import Cardano.Ledger.Era(SupportsSegWit(TxSeq)) +import Shelley.Spec.Ledger.BaseTypes(UnitInterval) +import Shelley.Spec.Ledger.Serialization(ToCBORGroup) +import Test.Shelley.Spec.Ledger.Generator.EraGen + ( EraGen (..), + genUtxo0, + MinLEDGER_STS, + MinCHAIN_STS, + ) -- ====================================================== + -- The CHAIN STS at the root of the STS allows for generating blocks of transactions -- with meaningful delegation certificates, protocol and application updates, withdrawals etc. instance ( EraGen era, - ShelleyTest era, UsesTxBody era, UsesTxOut era, UsesValue era, - PreAlonzo era, + ToCBORGroup (TxSeq era), UsesAuxiliary era, Mock (Crypto era), ApplyBlock era, GetLedgerView era, - ShelleyLedgerSTS era, - ShelleyChainSTS era, + MinLEDGER_STS era, + MinCHAIN_STS era, Embed (Core.EraRule "BBODY" era) (CHAIN era), Environment (Core.EraRule "BBODY" era) ~ BbodyEnv era, State (Core.EraRule "BBODY" era) ~ BbodyState era, @@ -109,6 +111,7 @@ instance Signal (Core.EraRule "TICK" era) ~ SlotNo, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), + HasField "_d" (Core.PParams era) UnitInterval, QC.HasTrace (Core.EraRule "LEDGERS" era) (GenEnv era) ) => HasTrace (CHAIN era) (GenEnv era) @@ -117,7 +120,7 @@ instance sigGen ge _env st = genBlock ge st - shrinkSignal = shrinkBlock + shrinkSignal = (\ _x -> []) -- shrinkBlock -- TO DO FIX ME type BaseEnv (CHAIN era) = Globals interpretSTS globals act = runIdentity $ runReaderT act globals @@ -135,7 +138,7 @@ lastByronHeaderHash _ = HashHeader $ mkHash 0 -- and (2) always return Right (since this function does not raise predicate failures). mkGenesisChainState :: forall era a. - ( ShelleyTest era, + ( Default (State (Core.EraRule "PPUP" era)), EraGen era ) => GenEnv era -> @@ -144,10 +147,10 @@ mkGenesisChainState :: mkGenesisChainState ge@(GenEnv _ constants) (IRC _slotNo) = do utxo0 <- genUtxo0 ge - pParams <- genPParams constants + pParams <- genEraPParams @era constants pure . Right . withRewards $ - initialShelleyState + initialShelleyState @era (At $ LastAppliedBlock (BlockNo 0) (SlotNo 0) (lastByronHeaderHash p)) epoch0 utxo0 @@ -190,7 +193,9 @@ mkOCertIssueNos (GenDelegs delegs0) = -- This allows stake pools to produce blocks from genesis. registerGenesisStaking :: forall era. - ShelleyTest era => + ( Era era, + HasField "address" (Core.TxOut era) (Addr (Crypto era)) + ) => ShelleyGenesisStaking (Crypto era) -> ChainState era -> ChainState era diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs index f8e0d4319e..783aa70d0e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs @@ -67,7 +67,6 @@ import Shelley.Spec.Ledger.API import Shelley.Spec.Ledger.BaseTypes (Globals, ShelleyBase) import Shelley.Spec.Ledger.Delegation.Certificates (isDeRegKey) import Shelley.Spec.Ledger.Keys (HasKeyRole (coerceKeyRole), asWitness) -import Shelley.Spec.Ledger.PParams (PParams, PParams' (..)) import Shelley.Spec.Ledger.STS.Delpl (DelplPredicateFailure) import Shelley.Spec.Ledger.Slot (SlotNo (..)) import Shelley.Spec.Ledger.TxBody (Ix) @@ -79,6 +78,7 @@ import Test.Shelley.Spec.Ledger.Generator.Delegation (CertCred (..), genDCert) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) import Test.Shelley.Spec.Ledger.Generator.ScriptClass (scriptKeyCombination) import Test.Shelley.Spec.Ledger.Utils (testGlobals) +import GHC.Records(HasField(getField)) -- | This is a non-spec STS used to generate a sequence of certificates with -- witnesses. @@ -103,12 +103,11 @@ instance Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, State (Core.EraRule "DELPL" era) ~ DPState (Crypto era), - Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era), - Core.PParams era ~ PParams era + Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era) ) => STS (CERTS era) where - type Environment (CERTS era) = (SlotNo, Ix, PParams era, AccountState) + type Environment (CERTS era) = (SlotNo, Ix, Core.PParams era, AccountState) type State (CERTS era) = (DPState (Crypto era), Ix) type Signal (CERTS era) = Maybe (DCert (Crypto era), CertCred era) type PredicateFailure (CERTS era) = CertsPredicateFailure era @@ -123,8 +122,7 @@ certsTransition :: ( Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, State (Core.EraRule "DELPL" era) ~ DPState (Crypto era), - Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era), - Core.PParams era ~ PParams era + Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era) ) => TransitionRule (CERTS era) certsTransition = do @@ -156,13 +154,11 @@ instance wrapFailed = CertsFailure instance - ( Era era, - EraGen era, + ( EraGen era, Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, State (Core.EraRule "DELPL" era) ~ DPState (Crypto era), - Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era), - Core.PParams era ~ PParams era + Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era) ) => QC.HasTrace (CERTS era) (GenEnv era) where @@ -192,15 +188,14 @@ instance -- deposits and refunds required. genDCerts :: forall era. - ( Embed (Core.EraRule "DELPL" era) (CERTS era), + ( EraGen era, + Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, State (Core.EraRule "DELPL" era) ~ DPState (Crypto era), - Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era), - Core.PParams era ~ PParams era, - EraGen era + Signal (Core.EraRule "DELPL" era) ~ DCert (Crypto era) ) => GenEnv era -> - PParams era -> + Core.PParams era -> DPState (Crypto era) -> SlotNo -> Natural -> @@ -238,7 +233,7 @@ genDCerts pure ( StrictSeq.fromList certs, totalDeposits pparams (_pParams (_pstate dpState)) certs, - (length deRegStakeCreds) <×> (_keyDeposit pparams), + (length deRegStakeCreds) <×> (getField @"_keyDeposit" pparams), lastState_, ( concat (keyCredAsWitness <$> keyCreds'), extractScriptCred <$> scriptCreds diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs index 9ffb2bc30b..9cb6a3bd95 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs @@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + -- The HasTrace instance relies on test generators and so cannot -- be included with the LEDGER STS {-# OPTIONS_GHC -Wno-orphans #-} @@ -45,14 +47,12 @@ import Shelley.Spec.Ledger.LedgerState UTxOState, genesisState, ) -import Shelley.Spec.Ledger.PParams (PParams' (..)) import Shelley.Spec.Ledger.STS.Delegs (DelegsEnv) import Shelley.Spec.Ledger.STS.Delpl (DELPL, DelplEnv, DelplPredicateFailure) import Shelley.Spec.Ledger.STS.Ledger (LEDGER, LedgerEnv (..)) import Shelley.Spec.Ledger.STS.Ledgers (LEDGERS, LedgersEnv (..)) import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv) import Shelley.Spec.Ledger.Slot (SlotNo (..)) -import Shelley.Spec.Ledger.Tx (Tx, WitnessSet) import Shelley.Spec.Ledger.TxBody (DCert, Ix, TxIn) import Test.QuickCheck (Gen) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) @@ -61,17 +61,16 @@ import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..), genCoin) import Test.Shelley.Spec.Ledger.Generator.EraGen ( EraGen (..), genUtxo0, + MinLEDGER_STS, ) import Test.Shelley.Spec.Ledger.Generator.Presets (genesisDelegs0) import Test.Shelley.Spec.Ledger.Generator.Trace.DCert (CERTS) -import Test.Shelley.Spec.Ledger.Generator.Update (genPParams) import Test.Shelley.Spec.Ledger.Generator.Utxo (genTx) import Test.Shelley.Spec.Ledger.Utils - ( ShelleyLedgerSTS, - ShelleyTest, - applySTSTest, + ( applySTSTest, runShelleyBase, ) +import Cardano.Ledger.Era(SupportsSegWit(TxInBlock)) -- ====================================================== @@ -85,14 +84,12 @@ genAccountState (Constants {minTreasury, maxTreasury, minReserves, maxReserves}) -- with meaningful delegation certificates. instance ( EraGen era, - Core.Witnesses era ~ WitnessSet era, - ShelleyTest era, UsesTxBody era, UsesTxOut era, UsesValue era, UsesAuxiliary era, Mock (Crypto era), - ShelleyLedgerSTS era, + MinLEDGER_STS era, TransValue ToCBOR era, Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, @@ -103,26 +100,27 @@ instance Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), Signal (Core.EraRule "DELEGS" era) ~ Seq (DCert (Crypto era)), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - Show (State (Core.EraRule "PPUP" era)) + Show (State (Core.EraRule "PPUP" era)), + Show (TxInBlock era) ) => TQC.HasTrace (LEDGER era) (GenEnv era) where envGen GenEnv {geConstants} = LedgerEnv <$> pure (SlotNo 0) <*> pure 0 - <*> genPParams geConstants + <*> genEraPParams @era geConstants <*> genAccountState geConstants - sigGen = genTx + sigGen genenv env state = unsafeApplyTx <$> genTx genenv env state - shrinkSignal _ = [] + shrinkSignal _ = [] -- TODO add some kind of Shrinker? type BaseEnv (LEDGER era) = Globals interpretSTS globals act = runIdentity $ runReaderT act globals @@ -130,13 +128,12 @@ instance instance forall era. ( EraGen era, - ShelleyTest era, UsesTxBody era, UsesTxOut era, UsesValue era, UsesAuxiliary era, Mock (Crypto era), - ShelleyLedgerSTS era, + MinLEDGER_STS era, Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, State (Core.EraRule "DELPL" era) ~ DPState (Crypto era), @@ -145,13 +142,14 @@ instance Embed (Core.EraRule "DELEG" era) (DELPL era), Embed (Core.EraRule "LEDGER" era) (LEDGERS era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)) + HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), + Default (State (Core.EraRule "PPUP" era)) ) => TQC.HasTrace (LEDGERS era) (GenEnv era) where envGen GenEnv {geConstants} = LedgersEnv <$> pure (SlotNo 0) - <*> genPParams geConstants + <*> genEraPParams @era geConstants <*> genAccountState geConstants -- a LEDGERS signal is a sequence of LEDGER signals @@ -168,12 +166,12 @@ instance pure $ Seq.fromList (reverse txs') -- reverse Newest first to Oldest first where genAndApplyTx :: - (UTxOState era, DPState (Crypto era), [Tx era]) -> + (UTxOState era, DPState (Crypto era), [TxInBlock era]) -> Ix -> - Gen (UTxOState era, DPState (Crypto era), [Tx era]) + Gen (UTxOState era, DPState (Crypto era), [TxInBlock era]) genAndApplyTx (u, dp, txs) ix = do let ledgerEnv = LedgerEnv slotNo ix pParams reserves - tx <- genTx ge ledgerEnv (u, dp) + tx <- unsafeApplyTx <$> genTx ge ledgerEnv (u, dp) let res = runShelleyBase $ @@ -199,7 +197,6 @@ instance mkGenesisLedgerState :: forall a era. ( UsesValue era, - UsesTxOut era, EraGen era, Default (State (Core.EraRule "PPUP" era)) ) => diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Update.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Update.hs index cfde501812..b1955c07ea 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Update.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Update.hs @@ -7,15 +7,25 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} module Test.Shelley.Spec.Ledger.Generator.Update ( genPParams, genUpdate, + genShelleyPParamsDelta, + genM, + genDecentralisationParam, ) where +import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.Core as Core(PParams,PParamsDelta) import Cardano.Ledger.Era (Crypto) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -53,11 +63,12 @@ import Shelley.Spec.Ledger.PParams ( PParams, PParams' (..), ProtVer (..), + PParamsUpdate, pattern ProposedPPUpdates, pattern Update, ) import Shelley.Spec.Ledger.Slot (EpochNo (EpochNo), SlotNo) -import Test.QuickCheck (Gen) +import Test.QuickCheck (Gen,frequency) import qualified Test.QuickCheck as QC import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Shelley.Spec.Ledger.Generator.Core @@ -70,10 +81,12 @@ import Test.Shelley.Spec.Ledger.Generator.Core ) import Test.Shelley.Spec.Ledger.Utils ( GenesisKeyPair, - ShelleyTest, epochFromSlotNo, unsafeMkUnitInterval, ) +import Cardano.Ledger.Core(PParamsDelta) + +-- ==================================== genRationalInThousands :: HasCallStack => Integer -> Integer -> Gen Rational genRationalInThousands lower upper = @@ -87,7 +100,7 @@ genIntervalInThousands :: HasCallStack => Word64 -> Word64 -> Gen UnitInterval genIntervalInThousands lower upper = unsafeMkUnitInterval <$> genRatioWord64InThousands lower upper -genPParams :: HasCallStack => Constants -> Gen (PParams era) +genPParams :: Constants -> Gen (PParams era) genPParams c@(Constants {maxMinFeeA, maxMinFeeB}) = mkPParams <$> genNatural 0 maxMinFeeA -- _minfeeA <*> genNatural 0 maxMinFeeB -- _minfeeB @@ -204,65 +217,78 @@ genNextProtocolVersion pp = do where ProtVer m n = _protocolVersion pp + +genM :: Gen a -> Gen (StrictMaybe a) +genM gen = frequency[(1,SJust <$> gen),(2,pure SNothing)] + +-- | This is only good in the Shelley Era, used to define the genEraPParamsDelta method for (EraGen (ShelleyEra c)) +genShelleyPParamsDelta:: forall era. + ( PParams era ~ Core.PParams era, + Core.PParamsDelta era ~ PParamsUpdate era + ) => + Constants -> + PParams era -> + Gen (PParamsDelta era) +genShelleyPParamsDelta (c@Constants {maxMinFeeA, maxMinFeeB}) pp = do + -- TODO generate Maybe types so not all updates are full + minFeeA <- genM $ genNatural 0 maxMinFeeA + minFeeB <- genM $ genNatural 0 maxMinFeeB + maxBBSize <- genM $ genNatural low hi + maxTxSize <- genM $ genNatural low hi + maxBHSize <- genM $ genNatural low hi + keyDeposit <- genM $ genKeyDeposit + poolDeposit <- genM $ genPoolDeposit + eMax <- genM $ genEMax c + nopt <- genM $ genNOpt + a0 <- genM $ genA0 + rho <- genM $ genRho + tau <- genM $ genTau + d <- genM $ genDecentralisationParam + extraEntropy <- genM $ genExtraEntropy + protocolVersion <- genM $ genNextProtocolVersion pp + minUTxOValue <- genM $ genMinUTxOValue + minPoolCost <- genM $ genMinPoolCost + pure(PParams + { _minfeeA = minFeeA, + _minfeeB = minFeeB, + _maxBBSize = maxBBSize, + _maxTxSize = maxTxSize, + _maxBHSize = maxBHSize, + _keyDeposit = keyDeposit, + _poolDeposit = poolDeposit, + _eMax = eMax, + _nOpt = nopt, + _a0 = a0, + _rho = rho, + _tau = tau, + _d = d, + _extraEntropy = extraEntropy, + _protocolVersion = protocolVersion, + _minUTxOValue = minUTxOValue, + _minPoolCost = minPoolCost + }) + -- | Generate a proposal for protocol parameter updates for all the given genesis keys. -- Return an empty update if it is too late in the epoch for updates. -genPPUpdate :: - HasCallStack => - ShelleyTest era => +genPPUpdate :: forall era. + (EraGen era) => Constants -> - PParams era -> + Core.PParams era -> [KeyHash 'Genesis (Crypto era)] -> Gen (ProposedPPUpdates era) -genPPUpdate (c@Constants {maxMinFeeA, maxMinFeeB}) pp genesisKeys = do - -- TODO generate Maybe tyes so not all updates are full - minFeeA <- genNatural 0 maxMinFeeA - minFeeB <- genNatural 0 maxMinFeeB - maxBBSize <- genNatural low hi - maxTxSize <- genNatural low hi - maxBHSize <- genNatural low hi - keyDeposit <- genKeyDeposit - poolDeposit <- genPoolDeposit - eMax <- genEMax c - nopt <- genNOpt - a0 <- genA0 - rho <- genRho - tau <- genTau - d <- genDecentralisationParam - extraEntropy <- genExtraEntropy - protocolVersion <- genNextProtocolVersion pp - minUTxOValue <- genMinUTxOValue - minPoolCost <- genMinPoolCost - let pps = - PParams - { _minfeeA = SJust minFeeA, - _minfeeB = SJust minFeeB, - _maxBBSize = SJust maxBBSize, - _maxTxSize = SJust maxTxSize, - _maxBHSize = SJust maxBHSize, - _keyDeposit = SJust keyDeposit, - _poolDeposit = SJust poolDeposit, - _eMax = SJust eMax, - _nOpt = SJust nopt, - _a0 = SJust a0, - _rho = SJust rho, - _tau = SJust tau, - _d = SJust d, - _extraEntropy = SJust extraEntropy, - _protocolVersion = SJust protocolVersion, - _minUTxOValue = SJust minUTxOValue, - _minPoolCost = SJust minPoolCost - } +genPPUpdate constants pp genesisKeys = do + pps <- genEraPParamsDelta @era constants pp let ppUpdate = zip genesisKeys (repeat pps) pure $ ProposedPPUpdates . Map.fromList $ ppUpdate -- | Generate an @Update (where all the given nodes participate) -genUpdateForNodes :: - (HasCallStack, ShelleyTest era) => +genUpdateForNodes :: forall era. + (EraGen era) => Constants -> SlotNo -> EpochNo -> -- current epoch [KeyPair 'Genesis (Crypto era)] -> - PParams era -> + Core.PParams era -> Gen (Maybe (Update era)) genUpdateForNodes c s e coreKeys pp = Just <$> (Update <$> genPPUpdate_ <*> pure e') @@ -271,14 +297,15 @@ genUpdateForNodes c s e coreKeys pp = genPPUpdate_ = genPPUpdate c pp genesisKeys e' = if tooLateInEpoch s then e + 1 else e + -- | Occasionally generate an update and return with the witness keys genUpdate :: - (HasCallStack, ShelleyTest era) => + (EraGen era) => Constants -> SlotNo -> [(GenesisKeyPair (Crypto era), AllIssuerKeys (Crypto era) 'GenesisDelegate)] -> Map (KeyHash 'GenesisDelegate (Crypto era)) (AllIssuerKeys (Crypto era) 'GenesisDelegate) -> - PParams era -> + Core.PParams era -> (UTxOState era, DPState (Crypto era)) -> Gen (Maybe (Update era), [KeyPair 'Witness (Crypto era)]) genUpdate diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs index e470d146dd..3f19f55d46 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs @@ -28,9 +28,7 @@ import Cardano.Ledger.Hashes (EraIndependentTxBody) import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) import Cardano.Ledger.Shelley.Constraints ( TransValue, - UsesAuxiliary, UsesScript, - UsesTxBody, UsesTxOut (..), UsesValue, ) @@ -49,7 +47,6 @@ import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set import GHC.Records (HasField (..)) -import GHC.Stack (HasCallStack) import Shelley.Spec.Ledger.API ( DCert, ScriptHash, @@ -83,15 +80,9 @@ import Shelley.Spec.Ledger.LedgerState _ptrs, _rewards, ) -import Shelley.Spec.Ledger.PParams (PParams, PParams' (..)) import Shelley.Spec.Ledger.STS.Delpl (DelplEnv) import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (..)) -import Shelley.Spec.Ledger.Tx - ( Tx (..), - TxIn (..), - WitnessSet, - WitnessSetHKD (..), - ) +import Shelley.Spec.Ledger.Tx(Tx(..), TxIn (..)) import Shelley.Spec.Ledger.TxBody (Wdrl (..)) import Shelley.Spec.Ledger.UTxO ( UTxO (..), @@ -117,30 +108,36 @@ import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) import Test.Shelley.Spec.Ledger.Generator.ScriptClass (scriptKeyCombination) import Test.Shelley.Spec.Ledger.Generator.Trace.DCert (CERTS, genDCerts) import Test.Shelley.Spec.Ledger.Generator.Update (genUpdate) -import Test.Shelley.Spec.Ledger.Utils (ShelleyTest, Split (..)) +import Test.Shelley.Spec.Ledger.Utils (Split (..)) +import Cardano.Ledger.Era(Era) +import NoThunks.Class() -- Instances only -- ======================================================= showBalance :: forall era. - ( ShelleyTest era, + ( Era era, + Show (Core.Value era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), - HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) + HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), + HasField "_keyDeposit" (Core.PParams era) Coin, + HasField "_poolDeposit" (Core.PParams era) Coin ) => LedgerEnv era -> UTxOState era -> DPState (Crypto era) -> - Tx era -> + Core.Tx era -> String showBalance (LedgerEnv _ _ pparams _) (UTxOState utxo _ _ _) (DPState _ (PState stakepools _ _)) - (Tx txBody _ _) = - "\n\nConsumed: " ++ show (consumed pparams utxo txBody) - ++ " Produced: " - ++ show (produced @era pparams stakepools txBody) + tx = "\n\nConsumed: " ++ show (consumed pparams utxo txBody) + ++ " Produced: " + ++ show (produced @era pparams stakepools txBody) + where txBody = getField @"body" tx + -- ======================================================================== @@ -163,9 +160,9 @@ showBalance genTx :: forall era. - ( HasCallStack, - ShelleyTest era, - EraGen era, + ( EraGen era, + UsesTxOut era, -- arises genInputs + UsesValue era, -- arises calcOutputsFromBalance Mock (Crypto era), Embed (Core.EraRule "DELPL" era) (CERTS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, @@ -176,7 +173,7 @@ genTx :: GenEnv era -> LedgerEnv era -> (UTxOState era, DPState (Crypto era)) -> - Gen (Tx era) + Gen (Core.Tx era) genTx ge@( GenEnv keySpace@KeySpace_ @@ -295,7 +292,7 @@ genTx data Delta era = Delta { dfees :: Coin, extraInputs :: Set.Set (TxIn (Crypto era)), - extraWitnesses :: WitnessSet era, + extraWitnesses :: Core.Witnesses era, change :: Core.TxOut era, deltaVKeys :: [KeyPair 'Witness (Crypto era)], deltaScripts :: [(Core.Script era, Core.Script era)] @@ -304,7 +301,12 @@ data Delta era = Delta -- | - We need this instance to know when delta has stopped growing. We don't -- actually need to compare all the fields, because if the extraInputs has not -- changed then the Scripts and keys will not have changed. -instance (UsesTxOut era, UsesScript era, TransValue Eq era) => Eq (Delta era) where +instance + ( UsesTxOut era, + UsesScript era, + TransValue Eq era, + Eq (Core.Witnesses era) + ) => Eq (Delta era) where a == b = dfees a == dfees b && extraInputs a == extraInputs b @@ -316,7 +318,8 @@ instance (UsesTxOut era, UsesScript era, TransValue Eq era) => Eq (Delta era) wh deltaZero :: forall era. ( UsesScript era, - UsesTxOut era + UsesTxOut era, + Monoid (Core.Witnesses era) ) => Coin -> Coin -> @@ -341,9 +344,9 @@ genNextDelta :: HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))) ) => UTxO era -> - PParams era -> + Core.PParams era -> KeySpace era -> - Tx era -> + Core.Tx era -> Delta era -> Gen (Delta era) genNextDelta @@ -370,11 +373,11 @@ genNextDelta encodedLen extraWitnesses ] - deltaFee = draftSize <×> Coin (fromIntegral (_minfeeA pparams)) + deltaFee = draftSize <×> Coin (fromIntegral (getField @"_minfeeA" pparams)) totalFee = baseTxFee <+> deltaFee :: Coin remainingFee = totalFee <-> dfees :: Coin changeAmount = getChangeAmount change - minAda = _minUTxOValue pparams + minAda = getField @"_minUTxOValue" pparams in if remainingFee <= Coin 0 -- we've paid for all the fees then pure delta -- we're done else -- the change covers what we need, so shift Coin from change to dfees. @@ -412,7 +415,7 @@ genNextDelta then error "Not enough money in the world" else pure () let newWits = - mkTxWits + mkTxWits @era ksIndexedPaymentKeys ksIndexedStakingKeys vkeyPairs @@ -451,15 +454,15 @@ genNextDeltaTilFixPoint :: KeyPairs (Crypto era) -> [(Core.Script era, Core.Script era)] -> UTxO era -> - PParams era -> + Core.PParams era -> KeySpace era -> - Tx era -> + Core.Tx era -> Gen (Delta era) genNextDeltaTilFixPoint initialfee keys scripts utxo pparams keySpace tx = do addr <- genRecipients @era 1 keys scripts fix (genNextDelta utxo pparams keySpace tx) - (deltaZero initialfee (safetyOffset <+> _minUTxOValue pparams) (head addr)) + (deltaZero initialfee (safetyOffset <+> getField @"_minUTxOValue" pparams) (head addr)) where -- add a small offset here to ensure outputs above minUtxo value safetyOffset = Coin 5 @@ -467,18 +470,15 @@ genNextDeltaTilFixPoint initialfee keys scripts utxo pparams keySpace tx = do applyDelta :: forall era. ( EraGen era, - UsesTxBody era, - UsesAuxiliary era, Mock (Crypto era), - HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - Core.Witnesses era ~ WitnessSet era + HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))) ) => [KeyPair 'Witness (Crypto era)] -> Map (ScriptHash (Crypto era)) (Core.Script era) -> KeySpace era -> - Tx era -> + Core.Tx era -> Delta era -> - Tx era + Core.Tx era applyDelta neededKeys neededScripts @@ -511,12 +511,9 @@ fix f d = do d1 <- f d; if d1 == d then pure d else fix f d1 converge :: ( EraGen era, - UsesTxBody era, UsesTxOut era, - UsesAuxiliary era, Mock (Crypto era), - HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - Core.Witnesses era ~ WitnessSet era + HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))) ) => Coin -> [KeyPair 'Witness (Crypto era)] -> @@ -524,10 +521,10 @@ converge :: KeyPairs (Crypto era) -> [(Core.Script era, Core.Script era)] -> UTxO era -> - PParams era -> + Core.PParams era -> KeySpace era -> - Tx era -> - Gen (Tx era) + Core.Tx era -> + Gen (Core.Tx era) converge initialfee neededKeys @@ -584,25 +581,22 @@ mkTxWits :: [KeyPair 'Witness (Crypto era)] -> Map (ScriptHash (Crypto era)) (Core.Script era) -> SafeHash (Crypto era) EraIndependentTxBody -> - WitnessSet era + Core.Witnesses era mkTxWits indexedPaymentKeys indexedStakingKeys awits msigs txBodyHash = - WitnessSet - { addrWits = - makeWitnessesVKey txBodyHash awits + genEraWitnesses @era + (makeWitnessesVKey txBodyHash awits `Set.union` makeWitnessesFromScriptKeys txBodyHash ( indexedPaymentKeysAsWitnesses `Map.union` indexedStakingKeysAsWitnesses ) - msigSignatures, - scriptWits = msigs, - bootWits = mempty - } + msigSignatures) + msigs where indexedPaymentKeysAsWitnesses = Map.fromAscList diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs index d427e46056..a178b29171 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs @@ -35,9 +35,6 @@ module Test.Shelley.Spec.Ledger.Utils GenesisKeyPair, getBlockNonce, ShelleyTest, - ShelleyUtxoSTS, - ShelleyLedgerSTS, - ShelleyChainSTS, ChainProperty, Split (..), ) @@ -100,18 +97,11 @@ import Data.Functor ((<&>)) import Data.Functor.Identity (runIdentity) import Data.Maybe (fromMaybe) import Data.Ratio (Ratio) -import Data.Sequence (Seq) import Data.Time.Clock.POSIX import Data.Word (Word64) import Shelley.Spec.Ledger.API ( ApplyBlock, - CHAIN, - ChainState, - DPState, GetLedgerView, - LedgerEnv, - LedgerState, - LedgersEnv, PParams, ) import Shelley.Spec.Ledger.Address (Addr, pattern Addr) @@ -137,10 +127,8 @@ import Shelley.Spec.Ledger.Keys vKey, pattern KeyPair, ) -import Shelley.Spec.Ledger.LedgerState (UTxOState (..)) import Shelley.Spec.Ledger.OCert (KESPeriod (..)) import Shelley.Spec.Ledger.PParams (PParamsUpdate) -import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv) import Shelley.Spec.Ledger.Slot (EpochNo, EpochSize (..), SlotNo) import Shelley.Spec.Ledger.Tx (Tx, TxOut, WitnessSet) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) @@ -148,6 +136,24 @@ import Test.Tasty.HUnit ( Assertion, (@?=), ) +import Cardano.Ledger.Era(SupportsSegWit(TxInBlock)) + +type ChainProperty era = + ( UsesTxOut era, + UsesPParams era, + UsesValue era, + UsesTxBody era, + UsesAuxiliary era, + Mock (Crypto era), + ApplyBlock era, + GetLedgerView era, + Show (TxInBlock era), + Eq (TxInBlock era) + ) + + + +-- ================================================ type ShelleyTest era = ( UsesTxBody era, @@ -160,51 +166,13 @@ type ShelleyTest era = Era.TxInBlock era ~ Tx era, TxOut era ~ Core.TxOut era, PParams era ~ Core.PParams era, - PParamsDelta era ~ PParamsUpdate era, + Core.PParamsDelta era ~ PParamsUpdate era, Core.Witnesses era ~ WitnessSet era, Split (Core.Value era), Default (State (Core.EraRule "PPUP" era)), Core.AnnotatedData (Core.Witnesses era) ) -type ChainProperty era = - ( ShelleyBased era, - Mock (Crypto era), - ShelleyUtxoSTS era, - ApplyBlock era, - GetLedgerView era - ) - -type ShelleyUtxoSTS era = - ( STS (Core.EraRule "UTXOW" era), - BaseM (Core.EraRule "UTXOW" era) ~ ShelleyBase, - State (Core.EraRule "UTXO" era) ~ UTxOState era, - State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, - Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era - ) - -type ShelleyLedgerSTS era = - ( STS (Core.EraRule "LEDGER" era), - BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase, - Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, - State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), - Signal (Core.EraRule "LEDGER" era) ~ Tx era, - STS (Core.EraRule "LEDGERS" era), - BaseM (Core.EraRule "LEDGERS" era) ~ ShelleyBase, - Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, - State (Core.EraRule "LEDGERS" era) ~ LedgerState era, - Signal (Core.EraRule "LEDGERS" era) ~ Seq (Tx era) - ) - -type ShelleyChainSTS era = - ( STS (CHAIN era), - BaseM (CHAIN era) ~ ShelleyBase, - Environment (CHAIN era) ~ (), - State (CHAIN era) ~ ChainState era, - Signal (CHAIN era) ~ Block era - ) class Split v where vsplit :: v -> Integer -> ([v], Coin) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs index 80db48912e..976f08dc05 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs @@ -11,7 +11,6 @@ module Test.Shelley.Spec.Ledger.Examples.EmptyBlock where import Cardano.Ledger.Era (Crypto (..)) -import Cardano.Ledger.Shelley.Constraints (UsesTxBody) import qualified Data.Map.Strict as Map import GHC.Stack (HasCallStack) import Shelley.Spec.Ledger.BaseTypes (Nonce) @@ -53,9 +52,8 @@ initStEx1 = initSt (UTxO Map.empty) blockEx1 :: forall era. ( HasCallStack, - PreAlonzo era, - ExMock (Crypto era), - UsesTxBody era + ShelleyTest era, + ExMock (Crypto era) ) => Block era blockEx1 = @@ -76,8 +74,8 @@ blockNonce :: forall era. ( HasCallStack, PreAlonzo era, - ExMock (Crypto era), - UsesTxBody era + ShelleyTest era, + ExMock (Crypto era) ) => Nonce blockNonce = getBlockNonce (blockEx1 @era) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs index 1c7c57c4d7..4c0a5ca0b8 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs @@ -11,6 +11,20 @@ module Test.Shelley.Spec.Ledger.PropertyTests ( propertyTests, minimalPropertyTests, + + relevantCasesAreCovered, + delegProperties, + poolProperties, + removedAfterPoolreap, + adaPreservationChain, + collisionFreeComplete, + onlyValidLedgerSignalsAreGenerated, + onlyValidChainSignalsAreGenerated, + -- Crypto era only + propCompactAddrRoundTrip, + propCompactSerializationAgree, + propDecompactAddrLazy, + propDecompactShelleyLazyAddr, ) where @@ -24,14 +38,14 @@ import Data.Sequence (Seq) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import GHC.Records (HasField (..)) -import Shelley.Spec.Ledger.API (CHAIN, DPState, DelegsEnv, Tx, PPUPState, UTxOState, UtxoEnv) +import Shelley.Spec.Ledger.API (CHAIN, DPState, DelegsEnv, PPUPState, UTxOState, UtxoEnv) import Shelley.Spec.Ledger.BaseTypes ( StrictMaybe (..), ) import Shelley.Spec.Ledger.Delegation.Certificates (DCert) import Shelley.Spec.Ledger.PParams (Update (..)) import Shelley.Spec.Ledger.STS.Ledger (LEDGER) -import Shelley.Spec.Ledger.TxBody (TxIn, Wdrl) +import Shelley.Spec.Ledger.TxBody (TxIn, Wdrl, WitVKey) import Test.Shelley.Spec.Ledger.Address.Bootstrap ( bootstrapHashTest, ) @@ -42,7 +56,7 @@ import Test.Shelley.Spec.Ledger.Address.CompactAddr propDecompactShelleyLazyAddr, ) import Test.Shelley.Spec.Ledger.ByronTranslation (testGroupByronTranslation) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv,PreAlonzo) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen) import Test.Shelley.Spec.Ledger.Rules.ClassifyTraces ( onlyValidChainSignalsAreGenerated, @@ -57,15 +71,20 @@ import Test.Shelley.Spec.Ledger.Rules.TestChain removedAfterPoolreap, ) import Test.Shelley.Spec.Ledger.ShelleyTranslation (testGroupShelleyTranslation) -import Test.Shelley.Spec.Ledger.Utils (ChainProperty, ShelleyTest) +import Test.Shelley.Spec.Ledger.Utils (ChainProperty) +import Cardano.Ledger.Era(SupportsSegWit(TxInBlock)) import Test.Tasty (TestTree, testGroup) import qualified Test.Tasty.QuickCheck as TQC +import Shelley.Spec.Ledger.Keys(KeyRole(Witness)) +import Shelley.Spec.Ledger.Scripts(ScriptHash) +import Data.Map(Map) + +-- ===================================================================== + minimalPropertyTests :: forall era. ( EraGen era, - ShelleyTest era, - PreAlonzo era, TransValue ToCBOR era, ChainProperty era, QC.HasTrace (CHAIN era) (GenEnv era), @@ -76,12 +95,13 @@ minimalPropertyTests :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, State (Core.EraRule "PPUP" era) ~ PPUPState era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), + Show (State (Core.EraRule "PPUP" era)) ) => TestTree @@ -105,8 +125,6 @@ minimalPropertyTests = propertyTests :: forall era. ( EraGen era, - ShelleyTest era, - PreAlonzo era, TransValue ToCBOR era, ChainProperty era, QC.HasTrace (CHAIN era) (GenEnv era), @@ -118,12 +136,14 @@ propertyTests :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, State (Core.EraRule "PPUP" era) ~ PPUPState era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), + HasField "addrWits" (Core.Witnesses era) (Set (WitVKey 'Witness (Crypto era))), + HasField "scriptWits" (Core.Witnesses era) (Map (ScriptHash (Crypto era)) (Core.Script era)), Show (State (Core.EraRule "PPUP" era)) ) => TestTree diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs index 616f4bd762..77c6c8c5b1 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs @@ -9,6 +9,12 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} + +{- | Currently this uses the trace mechansim to check that computing rewards has +a required set of properties. It works only in the Shelley Era. It could be +generalized, and then moved to the Generator/Trace/ directory which computes +property tests in all eras. +-} module Test.Shelley.Spec.Ledger.Rewards (rewardTests, C, defaultMain, newEpochProp) where import Cardano.Binary (toCBOR) @@ -143,6 +149,7 @@ import Control.State.Transition.Trace(SourceSignalTarget (..), sourceSignalTarge import Shelley.Spec.Ledger.STS.Chain (ChainState (..)) import Cardano.Ledger.Pretty(PrettyA(..)) + -- ======================================================================== -- Bounds and Constants -- @@ -729,6 +736,7 @@ lastElem [a] = Just a lastElem [] = Nothing lastElem (_ : xs) = lastElem xs + -- | Provide a legitimate NewEpochState to make an test Property newEpochProp :: Word64 -> (NewEpochState C -> Property) -> Property newEpochProp tracelen propf = withMaxSuccess 100 $ diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs index 9c28524598..1e205f6a1d 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs @@ -19,13 +19,10 @@ module Test.Shelley.Spec.Ledger.Rules.ClassifyTraces ) where -import Cardano.Binary (serialize') +import Cardano.Binary (ToCBOR,serialize') import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, TxInBlock) -import Cardano.Ledger.Shelley.Constraints - ( UsesTxBody, - UsesTxOut, - ) +import Cardano.Ledger.Era (Crypto, Era) +import Cardano.Ledger.Shelley.Constraints(UsesTxBody) import Cardano.Slotting.Slot (EpochSize (..)) import Control.State.Transition (STS (State)) import Control.State.Transition.Trace @@ -59,7 +56,6 @@ import Shelley.Spec.Ledger.API import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..), epochInfo) import Shelley.Spec.Ledger.BlockChain ( Block (..), - TxSeq (..), bhbody, bheader, bheaderSlotNo, @@ -84,11 +80,7 @@ import Shelley.Spec.Ledger.PParams ) import Shelley.Spec.Ledger.PParams as PParams (Update) import Shelley.Spec.Ledger.Slot (SlotNo (..), epochInfoSize) -import Shelley.Spec.Ledger.Tx (Tx (..)) -import Shelley.Spec.Ledger.TxBody - ( TxIn, - Wdrl (..), - ) +import Shelley.Spec.Ledger.TxBody(TxIn,Wdrl (..)) import Test.QuickCheck ( Property, checkCoverage, @@ -98,26 +90,27 @@ import Test.QuickCheck property, withMaxSuccess, ) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv, PreAlonzo) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen) import Test.Shelley.Spec.Ledger.Generator.Presets (genEnv) import Test.Shelley.Spec.Ledger.Generator.ShelleyEraGen () import Test.Shelley.Spec.Ledger.Generator.Trace.Chain (mkGenesisChainState) import Test.Shelley.Spec.Ledger.Generator.Trace.Ledger (mkGenesisLedgerState) import Test.Shelley.Spec.Ledger.Utils +import Cardano.Ledger.Era(SupportsSegWit(TxInBlock,fromTxSeq)) -- ================================================================= relevantCasesAreCovered :: forall era. ( EraGen era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), ChainProperty era, - PreAlonzo era, QC.HasTrace (CHAIN era) (GenEnv era), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "update" (Core.TxBody era) (StrictMaybe (PParams.Update era)) + -- HasField "address" (Core.TxOut era) (Addr (Crypto era)) ) => Property relevantCasesAreCovered = do @@ -134,20 +127,19 @@ relevantCasesAreCovered = do relevantCasesAreCoveredForTrace :: forall era. ( ChainProperty era, - UsesTxOut era, - PreAlonzo era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "update" (Core.TxBody era) (StrictMaybe (PParams.Update era)) + -- HasField "address" (Core.TxOut era) (Addr (Crypto era)) ) => Trace (CHAIN era) -> Property relevantCasesAreCoveredForTrace tr = do - let blockTxs :: Block era -> [Tx era] - blockTxs (Block _ (TxSeq txSeq)) = toList txSeq + let blockTxs :: Block era -> [TxInBlock era] + blockTxs (Block' _ txSeq _) = toList (fromTxSeq @era txSeq) bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) - certsByTx_ = certsByTx txs + certsByTx_ = certsByTx @era txs certs_ = concat certsByTx_ classifications = @@ -188,7 +180,7 @@ relevantCasesAreCoveredForTrace tr = do 60 ), ( "at least 10% of transactions have script TxOuts", - 0.1 < txScriptOutputsRatio @era (map (getField @"outputs" . getField @"body") txs), + 0.1 < txScriptOutputsRatio (Proxy @era) (map (getField @"outputs" . getField @"body") txs), 20 ), ( "at least 10% of `DCertDeleg` certificates have script credentials", @@ -196,15 +188,15 @@ relevantCasesAreCoveredForTrace tr = do 60 ), ( "at least 1 in 10 transactions have a reward withdrawal", - length txs < 10 * length (filter hasWithdrawal txs), + length txs < 10 * length (filter (hasWithdrawal @era) txs), 60 ), ( "at least 1 in 20 transactions have non-trivial protocol param updates", - length txs < 20 * length (filter hasPParamUpdate txs), + length txs < 20 * length (filter (hasPParamUpdate @era) txs), 60 ), ( "at least 1 in 20 transactions have metadata", - length txs < 20 * length (filter hasMetadata txs), + length txs < 20 * length (filter (hasMetadata @era) txs), 60 ), ( "at least 5 epochs in a trace, 20% of the time", @@ -246,9 +238,10 @@ scriptCredentialCertsRatio certs = -- | Extract the certificates from the transactions certsByTx :: forall era. - ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) + ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), + HasField "body" (TxInBlock era) (Core.TxBody era) ) => - [Tx era] -> + [TxInBlock era] -> [[DCert (Crypto era)]] certsByTx txs = toList . (getField @"certs") . getField @"body" <$> txs @@ -257,35 +250,39 @@ ratioInt x y = fromIntegral x / fromIntegral y -- | Transaction has script locked TxOuts -txScriptOutputsRatio :: - (UsesTxOut era) => +txScriptOutputsRatio :: forall era. + HasField "address" (Core.TxOut era) (Addr (Crypto era)) => + Proxy era -> [StrictSeq (Core.TxOut era)] -> Double -txScriptOutputsRatio txoutsList = +txScriptOutputsRatio _ txoutsList = ratioInt (sum (map countScriptOuts txoutsList)) (sum (map length txoutsList)) where + countScriptOuts :: StrictSeq (Core.TxOut era) -> Int countScriptOuts txouts = sum $ fmap - ( \out -> case getField @"address" out of + ( \out -> case (getField @"address" (out::Core.TxOut era)) of Addr _ (ScriptHashObj _) _ -> 1 _ -> 0 ) txouts hasWithdrawal :: - ( HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)) + ( HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), + HasField "body" (TxInBlock era) (Core.TxBody era) ) => - Tx era -> + TxInBlock era -> Bool -hasWithdrawal = not . null . unWdrl . (getField @"wdrls") . getField @"body" +hasWithdrawal x = (not . null . unWdrl . (getField @"wdrls") . getField @"body") x hasPParamUpdate :: - ( HasField "update" (Core.TxBody era) (StrictMaybe (PParams.Update era)) + ( HasField "update" (Core.TxBody era) (StrictMaybe (PParams.Update era)), + HasField "body" (TxInBlock era) (Core.TxBody era) ) => - Tx era -> + TxInBlock era -> Bool hasPParamUpdate tx = ppUpdates . getField @"update" . getField @"body" $ tx @@ -293,10 +290,10 @@ hasPParamUpdate tx = ppUpdates SNothing = False ppUpdates (SJust (Update (ProposedPPUpdates ppUpd) _)) = Map.size ppUpd > 0 -hasMetadata :: +hasMetadata :: forall era. ( UsesTxBody era ) => - Tx era -> + TxInBlock era -> Bool hasMetadata tx = f . getField @"adHash" . getField @"body" $ tx @@ -307,13 +304,9 @@ hasMetadata tx = onlyValidLedgerSignalsAreGenerated :: forall era. ( EraGen era, - UsesTxOut era, ChainProperty era, - Show (Core.PParams era), QC.HasTrace (LEDGER era) (GenEnv era), - Default (State (Core.EraRule "PPUP" era)), - Show (Core.Witnesses era), - TxInBlock era ~ Tx era + Default (State (Core.EraRule "PPUP" era)) ) => Property onlyValidLedgerSignalsAreGenerated = @@ -335,13 +328,11 @@ onlyValidLedgerSignalsAreGenerated = propAbstractSizeBoundsBytes :: forall era. ( EraGen era, - Show (Core.PParams era), - UsesTxOut era, ChainProperty era, QC.HasTrace (LEDGER era) (GenEnv era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - Default (State (Core.EraRule "PPUP" era)), - TxInBlock era ~ Tx era + ToCBOR(TxInBlock era), -- Arises from propAbstractSizeNotTooBig (which serializes) + Default (State (Core.EraRule "PPUP" era)) ) => Property propAbstractSizeBoundsBytes = property $ do @@ -353,9 +344,9 @@ propAbstractSizeBoundsBytes = property $ do (genEnv p) genesisLedgerSt $ \tr -> do - let txs :: [Tx era] + let txs :: [TxInBlock era] txs = traceSignals OldestFirst tr - all (\tx -> txsizeBound tx >= numBytes tx) txs + all (\tx -> txsizeBound (Proxy @era) tx >= numBytes tx) txs where p :: Proxy era p = Proxy @@ -366,13 +357,11 @@ propAbstractSizeBoundsBytes = property $ do propAbstractSizeNotTooBig :: forall era. ( EraGen era, - Show (Core.PParams era), ChainProperty era, - UsesTxOut era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), + ToCBOR (TxInBlock era), -- We need to serialize it to get its size. QC.HasTrace (LEDGER era) (GenEnv era), - Default (State (Core.EraRule "PPUP" era)), - TxInBlock era ~ Tx era + Default (State (Core.EraRule "PPUP" era)) ) => Property propAbstractSizeNotTooBig = property $ do @@ -384,14 +373,14 @@ propAbstractSizeNotTooBig = property $ do -- an acceptableMagnitude of three, though. acceptableMagnitude = (3 :: Integer) numBytes = toInteger . BS.length . serialize' - notTooBig txb = txsizeBound txb <= acceptableMagnitude * numBytes txb + notTooBig txb = txsizeBound (Proxy @era) txb <= acceptableMagnitude * numBytes txb forAllTraceFromInitState @(LEDGER era) testGlobals tl (genEnv p) genesisLedgerSt $ \tr -> do - let txs :: [Tx era] + let txs :: [TxInBlock era] txs = traceSignals OldestFirst tr all notTooBig txs where @@ -402,7 +391,7 @@ propAbstractSizeNotTooBig = property $ do onlyValidChainSignalsAreGenerated :: forall era. ( EraGen era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), ChainProperty era, QC.HasTrace (CHAIN era) (GenEnv era) ) => diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs index fdcdbafe11..832f3bff4b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs @@ -26,8 +26,7 @@ import Cardano.Binary (ToCBOR) import Cardano.Ledger.Coin import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) -import qualified Cardano.Ledger.Era as Era -import Cardano.Ledger.Shelley.Constraints (TransValue, UsesPParams, UsesTxOut, UsesValue) +import Cardano.Ledger.Shelley.Constraints (TransValue, UsesPParams, UsesValue) import Cardano.Ledger.Val ((<+>), (<->)) import qualified Cardano.Ledger.Val as Val (coin) import Cardano.Prelude (HasField (..)) @@ -43,8 +42,6 @@ import Control.State.Transition.Trace traceStates, ) import qualified Control.State.Transition.Trace as Trace -import Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitState) -import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC import Data.Foldable (fold, foldl', toList) import qualified Data.Map.Strict as Map import Data.Proxy @@ -66,15 +63,15 @@ import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) import Shelley.Spec.Ledger.BlockChain ( BHeader (..), Block (..), - TxSeq (..), bbody, bhbody, bheader, bheaderSlotNo, ) import Shelley.Spec.Ledger.EpochBoundary (obligation) +import Shelley.Spec.Ledger.Keys(KeyHash,KeyRole(Witness)) import Shelley.Spec.Ledger.LedgerState hiding (circulation) -import Shelley.Spec.Ledger.PParams (PParams' (..), ProtVer) +import Shelley.Spec.Ledger.PParams ( ProtVer) import Shelley.Spec.Ledger.Rewards (sumRewards) import Shelley.Spec.Ledger.STS.Chain (ChainState (..), totalAda, totalAdaPots) import Shelley.Spec.Ledger.STS.Deleg (DelegEnv (..)) @@ -84,7 +81,6 @@ import Shelley.Spec.Ledger.STS.Upec (votedValue) import Shelley.Spec.Ledger.Tx import Shelley.Spec.Ledger.TxBody import Shelley.Spec.Ledger.UTxO (balance, totalDeposits, txins, txouts, pattern UTxO) -import Test.QuickCheck import Test.Shelley.Spec.Ledger.Generator.Block (tickChainState) import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) @@ -108,11 +104,18 @@ import qualified Test.Shelley.Spec.Ledger.Rules.TestPool as TestPool import qualified Test.Shelley.Spec.Ledger.Rules.TestPoolreap as TestPoolreap import Test.Shelley.Spec.Ledger.Utils ( ChainProperty, - ShelleyTest, epochFromSlotNo, runShelleyBase, testGlobals, ) +import Data.Default.Class(Default) +import Cardano.Ledger.Era(SupportsSegWit(TxInBlock,fromTxSeq)) +import Shelley.Spec.Ledger.Scripts(ScriptHash) +import Data.Map(Map) +import Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitState) +import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC +import Test.QuickCheck(Property,Testable(..),withMaxSuccess,conjoin,(===),counterexample) + ------------------------------ -- Constants for Properties -- @@ -135,11 +138,9 @@ longTraceLen = 150 collisionFreeComplete :: forall era. ( EraGen era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), TransValue ToCBOR era, ChainProperty era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, QC.HasTrace (CHAIN era) (GenEnv era), Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, @@ -148,9 +149,11 @@ collisionFreeComplete :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), + HasField "addrWits" (Core.Witnesses era) (Set (WitVKey 'Witness (Crypto era))), + HasField "scriptWits" (Core.Witnesses era) (Map (ScriptHash (Crypto era)) (Core.Script era)), Show (State (Core.EraRule "PPUP" era)) ) => Property @@ -167,17 +170,14 @@ collisionFreeComplete = map requiredMSigSignaturesSubset ssts ] --- | Various preservation properties +-- | Various preservation propertiesC adaPreservationChain :: forall era. ( EraGen era, - ShelleyTest era, State (Core.EraRule "PPUP" era) ~ PPUPState era, TransValue ToCBOR era, ChainProperty era, QC.HasTrace (CHAIN era) (GenEnv era), - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -185,7 +185,7 @@ adaPreservationChain :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), @@ -216,13 +216,12 @@ adaPreservationChain = ] -- ADA should be preserved for all state transitions in the generated trace -checkPreservation :: +checkPreservation :: forall era. ( UsesValue era, HasField "_protocolVersion" (Core.PParams era) ProtVer, HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - Era.TxSeq era ~ TxSeq era, State (Core.EraRule "PPUP" era) ~ PPUPState era, HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), UsesPParams era @@ -327,7 +326,7 @@ checkPreservation SourceSignalTarget {source, target, signal} = <> (toDeltaCoin $ sumRewards prevPP (rs ru)) ] - txs' = toList $ (txSeqTxns' . bbody) signal + txs' = toList $ (fromTxSeq @era . bbody) signal txs = map dispTx (zip txs' [0 :: Int ..]) dispTx (tx, ix) = @@ -354,7 +353,8 @@ checkPreservation SourceSignalTarget {source, target, signal} = -- If we are not at an Epoch Boundary (i.e. epoch source == epoch target) -- then the total rewards should change only by withdrawals checkWithdrawlBound :: - ( Era.TxSeq era ~ TxSeq era, + ( SupportsSegWit era, + HasField "body" (TxInBlock era) (Core.TxBody era), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)) ) => SourceSignalTarget (CHAIN era) -> @@ -385,7 +385,6 @@ checkWithdrawlBound SourceSignalTarget {source, signal, target} = -- increases by Withdrawals min Fees (for all transactions in a block) utxoDepositsIncreaseByFeesWithdrawals :: ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)) ) => SourceSignalTarget (CHAIN era) -> @@ -403,7 +402,6 @@ utxoDepositsIncreaseByFeesWithdrawals SourceSignalTarget {source, signal, target -- increases by sum of withdrawals for all transactions in a block potsSumIncreaseWdrlsPerBlock :: ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)) ) => SourceSignalTarget (CHAIN era) -> @@ -421,12 +419,7 @@ potsSumIncreaseWdrlsPerBlock SourceSignalTarget {source, signal, target} = potsSumIncreaseWdrlsPerTx :: forall era. ( ChainProperty era, - Show (Core.Witnesses era), - UsesTxOut era, - UsesPParams era, TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -434,7 +427,7 @@ potsSumIncreaseWdrlsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -462,12 +455,7 @@ potsSumIncreaseWdrlsPerTx SourceSignalTarget {source = chainSt, signal = block} -- | (Utxo + Deposits + Fees) increases by the reward delta potsSumIncreaseByRewardsPerTx :: ( ChainProperty era, - UsesTxOut era, - Show (Core.Witnesses era), - UsesPParams era, TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -475,7 +463,7 @@ potsSumIncreaseByRewardsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -508,12 +496,7 @@ potsSumIncreaseByRewardsPerTx SourceSignalTarget {source = chainSt, signal = blo -- | The Rewards pot decreases by the sum of withdrawals in a transaction potsRewardsDecreaseByWdrlsPerTx :: ( ChainProperty era, - UsesPParams era, - UsesTxOut era, - Show (Core.Witnesses era), TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -521,7 +504,7 @@ potsRewardsDecreaseByWdrlsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -562,12 +545,7 @@ potsRewardsDecreaseByWdrlsPerTx SourceSignalTarget {source = chainSt, signal = b -- equals the sum of the created value. preserveBalance :: ( ChainProperty era, - UsesPParams era, - UsesTxOut era, - Show (Core.Witnesses era), TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -575,7 +553,7 @@ preserveBalance :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), Show (State (Core.EraRule "PPUP" era)), @@ -615,12 +593,7 @@ preserveBalance SourceSignalTarget {source = chainSt, signal = block} = preserveBalanceRestricted :: forall era. ( ChainProperty era, - UsesPParams era, - UsesTxOut era, - Show (Core.Witnesses era), TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -628,7 +601,7 @@ preserveBalanceRestricted :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), @@ -664,12 +637,7 @@ preserveBalanceRestricted SourceSignalTarget {source = chainSt, signal = block} preserveOutputsTx :: forall era. ( ChainProperty era, - UsesTxOut era, - Show (Core.Witnesses era), - UsesPParams era, TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -677,7 +645,7 @@ preserveOutputsTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -700,12 +668,7 @@ preserveOutputsTx SourceSignalTarget {source = chainSt, signal = block} = eliminateTxInputs :: forall era. ( ChainProperty era, - UsesTxOut era, - Show (Core.Witnesses era), - UsesPParams era, TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -713,7 +676,7 @@ eliminateTxInputs :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -737,12 +700,7 @@ eliminateTxInputs SourceSignalTarget {source = chainSt, signal = block} = newEntriesAndUniqueTxIns :: forall era. ( ChainProperty era, - UsesTxOut era, - UsesPParams era, TransValue ToCBOR era, - Show (Core.Witnesses era), - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -750,8 +708,7 @@ newEntriesAndUniqueTxIns :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, - -- HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -784,11 +741,8 @@ newEntriesAndUniqueTxIns SourceSignalTarget {source = chainSt, signal = block} = requiredMSigSignaturesSubset :: forall era. ( EraGen era, - UsesTxOut era, - Core.Witnesses era ~ WitnessSet era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, - UsesPParams era, + HasField "scriptWits" (Core.Witnesses era) (Map (ScriptHash (Crypto era)) (Core.Script era)), + HasField "addrWits" (Core.Witnesses era) (Set (WitVKey 'Witness (Crypto era))), TransValue ToCBOR era, ChainProperty era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), @@ -798,10 +752,8 @@ requiredMSigSignaturesSubset :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "_keyDeposit" (Core.PParams era) Coin, - HasField "_poolDeposit" (Core.PParams era) Coin, Show (State (Core.EraRule "PPUP" era)) ) => SourceSignalTarget (CHAIN era) -> @@ -816,34 +768,31 @@ requiredMSigSignaturesSubset SourceSignalTarget {source = chainSt, signal = bloc signaturesSubset SourceSignalTarget {signal = tx} = let khs = keyHashSet tx in property $ - all (existsReqKeyComb khs) (scriptWits . getField @"wits" $ tx) + all (existsReqKeyComb khs) (getField @"scriptWits" . getField @"wits" $ tx) existsReqKeyComb keyHashes msig = any (\kl -> (Set.fromList kl) `Set.isSubsetOf` keyHashes) (scriptKeyCombinations (Proxy @era) msig) - + keyHashSet :: TxInBlock era -> Set (KeyHash 'Witness (Crypto era)) keyHashSet tx_ = - Set.map witKeyHash (addrWits . getField @"wits" $ tx_) + Set.map witKeyHash (getField @"addrWits" . getField @"wits" $ tx_) --- | Check for absence of double spend in a block noDoubleSpend :: forall era. ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, - Eq (Core.Witnesses era), - Show (Core.Witnesses era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))) ) => SourceSignalTarget (CHAIN era) -> Property noDoubleSpend SourceSignalTarget {signal} = - [] === getDoubleInputs txs + [] === (getDoubleInputs txs) where - txs = toList $ (txSeqTxns' . bbody) signal + txs = toList $ (fromTxSeq @era . bbody) signal - getDoubleInputs :: [Tx era] -> [(Tx era, [Tx era])] + getDoubleInputs :: [TxInBlock era] -> [(TxInBlock era, [TxInBlock era])] getDoubleInputs [] = [] getDoubleInputs (t : ts) = lookForDoubleSpends t ts ++ getDoubleInputs ts - lookForDoubleSpends :: Tx era -> [Tx era] -> [(Tx era, [Tx era])] + lookForDoubleSpends :: TxInBlock era -> [TxInBlock era] -> [(TxInBlock era, [TxInBlock era])] lookForDoubleSpends _ [] = [] lookForDoubleSpends tx_j ts = if null doubles then [] else [(tx_j, doubles)] @@ -857,24 +806,24 @@ noDoubleSpend SourceSignalTarget {signal} = ts inps_j = getField @"inputs" $ getField @"body" tx_j -withdrawals :: +withdrawals :: forall era. ( HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), - Era.TxSeq era ~ TxSeq era + HasField "body" (TxInBlock era) (Core.TxBody era), + SupportsSegWit era ) => Block era -> Coin -withdrawals block = +withdrawals (Block' _ txseq _) = foldl' ( \c tx -> let wdrls = unWdrl $ getField @"wdrls" (getField @"body" tx) in c <> fold wdrls ) (Coin 0) - $ (txSeqTxns' . bbody) block + $ (fromTxSeq @era txseq) -txFees :: - ( ChainProperty era, - Era.TxSeq era ~ TxSeq era +txFees :: forall era. + ( ChainProperty era ) => Block era -> Coin @@ -882,7 +831,7 @@ txFees block = foldl' (\c tx -> c <> getField @"txfee" (getField @"body" tx)) (Coin 0) - $ (txSeqTxns' . bbody) block + $ (fromTxSeq @era . bbody) block -- | Check that deposits are always non-negative nonNegativeDeposits :: @@ -915,7 +864,7 @@ feesNonDecreasing SourceSignalTarget {source, target} = poolProperties :: forall era. ( EraGen era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), ChainProperty era, QC.HasTrace (CHAIN era) (GenEnv era), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) @@ -934,7 +883,6 @@ poolProperties = -- retirement. poolRetirement :: ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_eMax" (Core.PParams era) EpochNo, HasField "_minPoolCost" (Core.PParams era) Coin @@ -954,7 +902,6 @@ poolRetirement SourceSignalTarget {source = chainSt, signal = block} = -- in the retiring map. poolRegistration :: ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_eMax" (Core.PParams era) EpochNo, HasField "_minPoolCost" (Core.PParams era) Coin @@ -971,7 +918,6 @@ poolRegistration (SourceSignalTarget {source = chainSt, signal = block}) = -- POOL` transition. poolStateIsInternallyConsistent :: ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_eMax" (Core.PParams era) EpochNo, HasField "_minPoolCost" (Core.PParams era) Coin @@ -993,7 +939,7 @@ poolStateIsInternallyConsistent (SourceSignalTarget {source = chainSt, signal = delegProperties :: forall era. ( EraGen era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), QC.HasTrace (CHAIN era) (GenEnv era), ChainProperty era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) @@ -1027,12 +973,7 @@ delegProperties = ledgerTraceFromBlock :: forall era. ( ChainProperty era, - UsesTxOut era, - UsesPParams era, - Show (Core.Witnesses era), TransValue ToCBOR era, - Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), @@ -1040,7 +981,7 @@ ledgerTraceFromBlock :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ Tx era, + Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -1061,7 +1002,6 @@ ledgerTraceFromBlock chainSt block = poolTraceFromBlock :: forall era. ( ChainProperty era, - Era.TxSeq era ~ TxSeq era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_eMax" (Core.PParams era) EpochNo, HasField "_minPoolCost" (Core.PParams era) Coin @@ -1091,8 +1031,7 @@ poolTraceFromBlock chainSt block = delegTraceFromBlock :: forall era. ( ChainProperty era, - HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - Era.TxSeq era ~ TxSeq era + HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) ) => ChainState era -> Block era -> @@ -1123,18 +1062,17 @@ delegTraceFromBlock chainSt block = -- NOTE: we need to tick the slot before processing transactions -- (in the same way that the CHAIN rule TICKs the slot before processing -- transactions with the LEDGERS rule) -ledgerTraceBase :: +ledgerTraceBase :: forall era. ( Era era, GetLedgerView era, - ApplyBlock era, - Era.TxSeq era ~ TxSeq era + ApplyBlock era ) => ChainState era -> Block era -> ( ChainState era, LedgerEnv era, (UTxOState era, DPState (Crypto era)), - [Tx era] + [TxInBlock era] ) ledgerTraceBase chainSt block = ( tickedChainSt, @@ -1143,14 +1081,14 @@ ledgerTraceBase chainSt block = txs ) where - (Block (BHeader bhb _) txSeq) = block + (Block' (BHeader bhb _) txSeq _) = block slot = bheaderSlotNo bhb tickedChainSt = tickChainState slot chainSt nes = (nesEs . chainNes) tickedChainSt pp_ = esPp nes LedgerState utxoSt0 delegSt0 = esLState nes -- Oldest to Newest first - txs = (reverse . toList . txSeqTxns') txSeq + txs = (reverse . toList . (fromTxSeq @era)) txSeq -- HERE WE USE SOME SegWit function -- | Transform the [(source, signal, target)] of a CHAIN Trace -- by manually applying the Chain TICK Rule to each source and producing @@ -1183,7 +1121,7 @@ chainSstWithTick ledgerTr = removedAfterPoolreap :: forall era. ( ChainProperty era, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), EraGen era, QC.HasTrace (CHAIN era) (GenEnv era) ) => @@ -1197,7 +1135,7 @@ removedAfterPoolreap = poolState = _pstate . _delegationState . esLState . nesEs . chainNes removedAfterPoolreap_ :: SourceSignalTarget (CHAIN era) -> Property - removedAfterPoolreap_ (SourceSignalTarget {source, target, signal = (Block bh _)}) = + removedAfterPoolreap_ (SourceSignalTarget {source, target, signal = (Block' bh _ _)}) = let e = (epochFromSlotNo . bheaderSlotNo . bhbody) bh in TestPoolreap.removedAfterPoolreap (poolState source) (poolState target) e @@ -1208,7 +1146,7 @@ removedAfterPoolreap = forAllChainTrace :: forall era prop. ( Testable prop, - ShelleyTest era, + Default (State (Core.EraRule "PPUP" era)), EraGen era, QC.HasTrace (CHAIN era) (GenEnv era) ) =>