From ee7b565444a94b8972f2e80b9bc6edafeeb2e4c9 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Mon, 21 Jun 2021 16:58:02 -0700 Subject: [PATCH] Added 2 arg scripts, and associated helper functions. (pay,stake) script pairs now may have plutus in both parts. Added the use of plutus scripts in minting as well. Discards are now traced to avoid silence. Now we use valueFromList rather than Map.singleton to make Values, this avoids the introduction of non-canonical values. Added an example of how to profile a property test. --- alonzo/impl/cardano-ledger-alonzo.cabal | 1 + .../impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 4 +- alonzo/test/cardano-ledger-alonzo-test.cabal | 2 +- .../Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 108 +++++++++++------ .../Cardano/Ledger/Alonzo/PlutusScripts.hs | 89 ++++++++++++++ .../test/Test/Cardano/Ledger/Alonzo/Golden.hs | 111 +++++------------- cardano-ledger-test/benchProperty/Main.hs | 60 ++++++++++ cardano-ledger-test/cardano-ledger-test.cabal | 31 ++++- nix/haskell.nix | 1 + plutus-preprocessor/src/Main.hs | 25 ++++ plutus-preprocessor/src/PlutusScripts.hs | 25 ++++ .../impl/src/Cardano/Ledger/Mary/Value.hs | 16 ++- .../src/Test/Cardano/Ledger/MaryEraGen.hs | 7 +- .../bench/Shelley/Spec/Ledger/Bench/Gen.hs | 2 +- .../Shelley/Spec/Ledger/Bench/Rewards.hs | 2 +- .../shelley-spec-ledger-test.cabal | 3 +- .../Shelley/Spec/Ledger/Generator/Core.hs | 60 ++++++---- .../Shelley/Spec/Ledger/Generator/EraGen.hs | 57 +++++++-- .../Shelley/Spec/Ledger/Generator/Presets.hs | 12 +- .../Spec/Ledger/Generator/ScriptClass.hs | 8 ++ .../Shelley/Spec/Ledger/Generator/Utxo.hs | 17 +-- 21 files changed, 470 insertions(+), 171 deletions(-) create mode 100644 cardano-ledger-test/benchProperty/Main.hs diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal index 1e13dfd19a1..cf5c390c249 100644 --- a/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/alonzo/impl/cardano-ledger-alonzo.cabal @@ -66,6 +66,7 @@ library plutus-ledger-api, plutus-tx, plutus-core, + prettyprinter, serialise, shelley-spec-ledger, small-steps, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index c344f76a99b..e9cdb2a6f6d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -52,6 +52,7 @@ import Cardano.Ledger.Pretty ppInteger, ppMap, ppRecord, + ppScriptHash, ppSexp, ppString, ppWord64, @@ -77,6 +78,7 @@ import NoThunks.Class (InspectHeapNamed (..), NoThunks) import Numeric.Natural (Natural) import Plutus.V1.Ledger.Api (defaultCostModelParams, validateCostModelParams) import qualified Plutus.V1.Ledger.Examples as Plutus (alwaysFailingNAryFunction, alwaysSucceedingNAryFunction) +import qualified Prettyprinter as PP -- | Marker indicating the part of a transaction for which this script is acting -- as a validator. @@ -273,7 +275,7 @@ ppTag x = ppString (show x) instance PrettyA Tag where prettyA = ppTag ppScript :: forall era. (ValidateScript era, Core.Script era ~ Script era) => Script era -> PDoc -ppScript (s@(PlutusScript _)) = ppString ("PlutusScript " ++ show (hashScript @era s)) +ppScript (s@(PlutusScript _)) = ppString "PlutusScript " PP.<+> ppScriptHash (hashScript @era s) ppScript (TimelockScript x) = ppTimelock x instance (ValidateScript era, Core.Script era ~ Script era) => PrettyA (Script era) where prettyA = ppScript diff --git a/alonzo/test/cardano-ledger-alonzo-test.cabal b/alonzo/test/cardano-ledger-alonzo-test.cabal index 71b26b98624..29bb5bde20f 100644 --- a/alonzo/test/cardano-ledger-alonzo-test.cabal +++ b/alonzo/test/cardano-ledger-alonzo-test.cabal @@ -72,12 +72,12 @@ 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 Test.Cardano.Ledger.Alonzo.Translation Test.Cardano.Ledger.Alonzo.Serialisation.CDDL + Test.Cardano.Ledger.Alonzo.Trials build-depends: base16-bytestring, bytestring, diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index 2201afac19d..33a1f0efa32 100644 --- a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -50,7 +50,7 @@ import Cardano.Ledger.Era (Crypto, Era (..), ValidateScript (..)) import Cardano.Ledger.Hashes (ScriptHash) import Cardano.Ledger.Keys (KeyHash, KeyRole (Witness)) import Cardano.Ledger.Mary (MaryEra) -import Cardano.Ledger.Mary.Value (policies) +import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..), Value, policies, valueFromList) import Cardano.Ledger.ShelleyMA.AuxiliaryData as Mary (pattern AuxiliaryData) import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) import Cardano.Ledger.Tx (Tx (Tx)) @@ -58,6 +58,7 @@ import Cardano.Ledger.Val (adaOnly, (<+>), (<×>)) import Cardano.Slotting.Slot (SlotNo (..)) import Control.Iterate.SetAlgebra (eval, (◁)) import Control.Monad (replicateM) +import qualified Data.ByteString.Char8 as BS import Data.Hashable (Hashable (..)) import qualified Data.List as List import Data.Map as Map @@ -75,7 +76,15 @@ import Shelley.Spec.Ledger.PParams (Update) import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl) import Shelley.Spec.Ledger.UTxO (UTxO (..)) import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval) -import Test.Cardano.Ledger.Alonzo.PlutusScripts (evendata3, guessTheNumber3, odddata3) +import Test.Cardano.Ledger.Alonzo.PlutusScripts + ( evenRedeemer2, + evendata3, + guessTheNumber3, + oddRedeemer2, + odddata3, + redeemerIs102, + sumsTo103, + ) import Test.Cardano.Ledger.MaryEraGen (addTokens, genMint, maryGenesisValue, policyIndex) import Test.QuickCheck hiding ((><)) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) @@ -83,7 +92,8 @@ import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Shelley.Spec.Ledger.Generator.Core ( GenEnv (..), ScriptInfo, - TwoPhaseInfo (..), + TwoPhase2ArgInfo (..), + TwoPhase3ArgInfo (..), findPlutus, genNatural, hashData, @@ -92,8 +102,10 @@ 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) -import Test.Shelley.Spec.Ledger.Generator.Utxo (encodedLen) +import Test.Shelley.Spec.Ledger.Generator.Utxo (encodedLen, myDiscard) +-- import Debug.Trace(trace) +-- import Cardano.Ledger.Pretty(PrettyA(..)) -- ============================================================ isKeyHashAddr :: Addr crypto -> Bool @@ -107,17 +119,37 @@ vKeyLocked txout = isKeyHashAddr (getField @"address" txout) && adaOnly (getField @"value" txout) -phase2scripts :: forall c. Mock c => [TwoPhaseInfo (AlonzoEra c)] -phase2scripts = - [ TwoPhaseInfo (alwaysSucceeds 3) (hashScript @(AlonzoEra c) (alwaysSucceeds 3)) (P.I 1) (P.I 1, bigMem, bigStep), - TwoPhaseInfo (alwaysSucceeds 3) (hashScript @(AlonzoEra c) (alwaysSucceeds 3)) (P.I 1) (P.I 1, bigMem, bigStep), - TwoPhaseInfo (alwaysSucceeds 3) (hashScript @(AlonzoEra c) (alwaysSucceeds 3)) (P.I 1) (P.I 1, bigMem, bigStep), - TwoPhaseInfo (alwaysSucceeds 3) (hashScript @(AlonzoEra c) (alwaysSucceeds 3)) (P.I 1) (P.I 1, bigMem, bigStep), - TwoPhaseInfo guessTheNumber3 (hashScript @(AlonzoEra c) guessTheNumber3) (P.I 9) (P.I 9, bigMem, bigStep), - TwoPhaseInfo evendata3 (hashScript @(AlonzoEra c) evendata3) (P.I 8) (P.I 8, bigMem, bigStep), - TwoPhaseInfo odddata3 (hashScript @(AlonzoEra c) odddata3) (P.I 9) (P.I 9, bigMem, bigStep) +phase2scripts3Arg :: forall c. Mock c => [TwoPhase3ArgInfo (AlonzoEra c)] +phase2scripts3Arg = + [ TwoPhase3ArgInfo (alwaysSucceeds 3) (hashScript @(AlonzoEra c) (alwaysSucceeds 3)) (P.I 1) (P.I 1, bigMem, bigStep), + TwoPhase3ArgInfo guessTheNumber3 (hashScript @(AlonzoEra c) guessTheNumber3) (P.I 9) (P.I 9, bigMem, bigStep), + TwoPhase3ArgInfo evendata3 (hashScript @(AlonzoEra c) evendata3) (P.I 8) (P.I 8, bigMem, bigStep), + TwoPhase3ArgInfo odddata3 (hashScript @(AlonzoEra c) odddata3) (P.I 9) (P.I 9, bigMem, bigStep), + TwoPhase3ArgInfo sumsTo103 (hashScript @(AlonzoEra c) sumsTo103) (P.I 1) (P.I 9, bigMem, bigStep) + ] + +phase2scripts2Arg :: forall c. Mock c => [TwoPhase2ArgInfo (AlonzoEra c)] +phase2scripts2Arg = + [ TwoPhase2ArgInfo (alwaysSucceeds 2) (hashScript @(AlonzoEra c) (alwaysSucceeds 2)) (P.I 1, bigMem, bigStep), + TwoPhase2ArgInfo oddRedeemer2 (hashScript @(AlonzoEra c) oddRedeemer2) (P.I 13, bigMem, bigStep), + TwoPhase2ArgInfo evenRedeemer2 (hashScript @(AlonzoEra c) evenRedeemer2) (P.I 14, bigMem, bigStep), + TwoPhase2ArgInfo redeemerIs102 (hashScript @(AlonzoEra c) redeemerIs102) (P.I 10, bigMem, bigStep) ] +genPlutus2Arg :: Mock c => Gen (Maybe (TwoPhase2ArgInfo (AlonzoEra c))) +genPlutus2Arg = frequency [(10, Just <$> elements phase2scripts2Arg), (90, pure Nothing)] + +-- | Gen a Mint value in the Alonzo Era, with a 10% chance that it includes an AlonzoScript +genAlonzoMint :: Mock c => Value c -> Gen (Value c, [Alonzo.Script (AlonzoEra c)]) +genAlonzoMint startvalue = do + ans <- genPlutus2Arg + case ans of + Nothing -> pure (startvalue, []) + Just (TwoPhase2ArgInfo script shash _) -> do + count <- chooseEnum (1, 10) + let assetname = AssetName . BS.pack $ "purple" + pure (((valueFromList 0 [(PolicyID shash, assetname, count)]) <> startvalue), [script]) + -- ================================================================ -- | A cost model that sets everything as being free @@ -204,11 +236,12 @@ genAlonzoTxBody _genenv utxo pparams currentslot input txOuts certs wdrls fee up _low <- genM (genSlotAfter currentslot) _high <- genM (genSlotAfter (currentslot + 50)) netid <- genM $ pure Testnet -- frequency [(2, pure Mainnet), (1, pure Testnet)] - minted <- genMint + startvalue <- genMint + (minted, plutusScripts) <- genAlonzoMint startvalue let (minted2, txouts2) = 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) + scriptsFromPolicies = List.map (\p -> (Map.!) policyIndex p) (Set.toList $ policies startvalue) txouts3 = fmap addMaybeDataHashToTxOut txouts2 validityInterval <- genValidityInterval currentslot return @@ -228,7 +261,7 @@ genAlonzoTxBody _genenv utxo pparams currentslot input txOuts certs wdrls fee up (hashWitnessPPData pparams (langsUsed @(AlonzoEra c) Map.empty) (Redeemers Map.empty) (TxDats Map.empty)) auxDHash netid, - List.map TimelockScript scriptsFromPolicies + (List.map TimelockScript scriptsFromPolicies <> plutusScripts) ) genSlotAfter :: SlotNo -> Gen SlotNo @@ -288,7 +321,8 @@ instance HasField "totExunits" (Tx (AlonzoEra c)) ExUnits where instance Mock c => EraGen (AlonzoEra c) where genEraAuxiliaryData = genAux genGenesisValue = maryGenesisValue - genEraTwoPhaseScripts = phase2scripts + genEraTwoPhase3Arg = phase2scripts3Arg + genEraTwoPhase2Arg = phase2scripts2Arg genEraTxBody = genAlonzoTxBody updateEraTxBody utxo pp witnesses txb coinx txin txout = new @@ -333,9 +367,11 @@ instance Mock c => EraGen (AlonzoEra c) where Just script -> if isNativeScript @(AlonzoEra c) script then ans -- Native scripts don't have redeemers - else case Map.lookup hash1 scriptinfo of -- It should be one of the known Plutus Scripts - Nothing -> ans - Just info -> addRedeemMap txbody info purpose ans -- Add it to the redeemer map + else case Map.lookup hash1 (fst scriptinfo) of -- It could be one of the known 3-Arg Plutus Scripts + Just info -> addRedeemMap txbody (getRedeemer3 info) purpose ans -- Add it to the redeemer map + Nothing -> case Map.lookup hash1 (snd scriptinfo) of -- It could be one of the known 2-Arg Plutus Scripts + Just info -> addRedeemMap txbody (getRedeemer2 info) purpose ans -- Add it to the redeemer map + Nothing -> ans unsafeApplyTx (Tx bod wit auxdata) = ValidatedTx bod wit (IsValidating True) auxdata @@ -343,8 +379,8 @@ instance Mock c => EraGen (AlonzoEra c) where genEraScriptCost pp script = if isPlutusScript script - then case List.find (\info -> (getScript @(AlonzoEra c) info) == script) genEraTwoPhaseScripts of - Just (TwoPhaseInfo _script _hash inputdata (rdmr, mems, steps)) -> + then case List.find (\info -> (getScript3 @(AlonzoEra c) info) == script) genEraTwoPhase3Arg of + Just (TwoPhase3ArgInfo _script _hash inputdata (rdmr, mems, steps)) -> scriptfee (getField @"_prices" pp) (ExUnits mems steps) <+> storageCost 10 pp (rdmr, ExUnits mems steps) -- Extra 10 for the RdmrPtr <+> storageCost 32 pp inputdata -- Extra 32 for the hash @@ -357,8 +393,8 @@ instance Mock c => EraGen (AlonzoEra c) where theFee = getField @"txfee" txb -- Coin supplied to pay fees minimumFee = minfee @(AlonzoEra c) pp tx in if (minimumFee <= theFee) - then pure tx - else discard + then (pure tx) + else myDiscard "MinFeee violation: genEraDne: AlonzoEraGem.hs" genEraTweakBlock pp txns = let txTotal, ppMax :: ExUnits @@ -366,7 +402,7 @@ instance Mock c => EraGen (AlonzoEra c) where ppMax = getField @"_maxBlockExUnits" pp in if pointWiseExUnits (<=) txTotal ppMax then pure txns - else discard + else myDiscard "TotExUnits violation: genEraTweakBlock: AlonzoEraGem.hs" storageCost :: ToCBOR t => Integer -> (Alonzo.PParams era) -> t -> Coin storageCost extra pp x = (extra + encodedLen x) <×> Coin (fromIntegral (getField @"_minfeeA" pp)) @@ -374,11 +410,11 @@ storageCost extra pp x = (extra + encodedLen x) <×> Coin (fromIntegral (getFiel addRedeemMap :: forall c. TxBody (AlonzoEra c) -> - TwoPhaseInfo (AlonzoEra c) -> + (Plutus.Data, Word64, Word64) -> ScriptPurpose c -> Map RdmrPtr (Data (AlonzoEra c), ExUnits) -> Map RdmrPtr (Data (AlonzoEra c), ExUnits) -addRedeemMap body1 (TwoPhaseInfo _ _ _ (dat, space, steps)) purpose ans = +addRedeemMap body1 (dat, space, steps) purpose ans = case (purpose, rdptr @(AlonzoEra c) body1 purpose) of (Spending _, SJust ptr) -> Map.insert ptr (Data dat, ExUnits space steps) ans (Minting _, SJust ptr) -> Map.insert ptr (Data dat, ExUnits space steps) ans @@ -387,12 +423,12 @@ addRedeemMap body1 (TwoPhaseInfo _ _ _ (dat, space, steps)) purpose ans = _ -> ans getDataMap :: forall era. Era era => ScriptInfo era -> Map (ScriptHash (Crypto era)) (Core.Script era) -> Map (DataHash (Crypto era)) (Data era) -getDataMap scriptinfo scrips = Map.foldlWithKey' accum Map.empty scrips +getDataMap (scriptinfo3, _) scrips = Map.foldlWithKey' accum Map.empty scrips where accum ans hsh _script = - case Map.lookup hsh scriptinfo of + case Map.lookup hsh scriptinfo3 of Nothing -> ans - Just (TwoPhaseInfo _script _hash dat _redeem) -> Map.insert (hashData @era dat) (Data dat) ans + Just (TwoPhase3ArgInfo _script _hash dat _redeem) -> Map.insert (hashData @era dat) (Data dat) ans instance Mock c => MinGenTxout (AlonzoEra c) where calcEraMinUTxO tout pp = (utxoEntrySize tout <×> getField @"_coinsPerUTxOWord" pp) @@ -406,24 +442,24 @@ instance Mock c => MinGenTxout (AlonzoEra c) where pure (zipWith makeTxOut addrs values) -- | If an Address is script address, we can find a potential data hash for it from --- genEraTwoPhaseScripts, which contains all known plutus scripts in the tests set. +-- genEraTwoPhase3Arg, which contains all known 3 arg plutus scripts in the tests set. -- If the script has is not in that map, then its data hash is SNothing. dataFromAddr :: forall c. Mock c => Addr c -> StrictMaybe (DataHash c) dataFromAddr (Addr _network (ScriptHashObj shash) _stakeref) = - case List.find (\info -> shash == hashScript @(AlonzoEra c) (getScript @(AlonzoEra c) info)) genEraTwoPhaseScripts of - Just info -> SJust (hashData @(AlonzoEra c) (getData info)) + case List.find (\info -> shash == hashScript @(AlonzoEra c) (getScript3 @(AlonzoEra c) info)) genEraTwoPhase3Arg of + Just info -> SJust (hashData @(AlonzoEra c) (getData3 info)) Nothing -> SNothing dataFromAddr _ = SNothing -- | We can find the data associated with the data hashes in the TxOuts, since --- genEraTwoPhaseScripts, which contains all known plutus scripts stores the data. +-- genEraTwoPhase3Arg, which contains all known 3 arg plutus scripts stores the data. dataMapFromTxOut :: forall c. Mock c => [TxOut (AlonzoEra c)] -> TxDats (AlonzoEra c) -> TxDats (AlonzoEra c) dataMapFromTxOut txouts datahashmap = Prelude.foldl accum datahashmap txouts where accum !ans (TxOut _ _ SNothing) = ans accum !ans (TxOut _ _ (SJust dhash)) = - case List.find (\info -> hashData @(AlonzoEra c) (getData info) == dhash) (genEraTwoPhaseScripts @(AlonzoEra c)) of - Just info -> let TxDats' m = ans in TxDats (Map.insert dhash (Data (getData info)) m) + case List.find (\info -> hashData @(AlonzoEra c) (getData3 info) == dhash) (genEraTwoPhase3Arg @(AlonzoEra c)) of + Just info -> let TxDats' m = ans in TxDats (Map.insert dhash (Data (getData3 info)) m) Nothing -> ans addMaybeDataHashToTxOut :: Mock c => TxOut (AlonzoEra c) -> TxOut (AlonzoEra c) diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/PlutusScripts.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/PlutusScripts.hs index 89734a2297c..e807ca29c18 100644 --- a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/PlutusScripts.hs +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/PlutusScripts.hs @@ -292,3 +292,92 @@ sumsTo103 = [0, 16, 144, 1, 0, 0, 9, 0, 0, 8, 144, 0, 0, 144, 0], [0, 129] ] + +{- Preproceesed Plutus Script +oddRedeemer2'_0 :: PlutusTx.Data.Data -> PlutusTx.Data.Data -> () +oddRedeemer2'_0 (PlutusTx.Data.I n_1) _d3_2 = if PlutusTx.Prelude.modulo n_1 2 PlutusTx.Eq.== 1 + then GHC.Tuple.() + else PlutusTx.Prelude.error GHC.Tuple.() +-} + +oddRedeemer2 :: Script era +oddRedeemer2 = + (PlutusScript . pack . concat) + [ [88, 254, 1, 0, 0, 51, 50, 0, 32, 2, 0, 50, 0, 50, 0], + [51, 32, 2, 0, 51, 50, 0, 32, 2, 0, 51, 51, 51, 32, 2], + [0, 32, 2, 0, 32, 2, 0, 51, 32, 2, 0, 50, 0, 50, 0], + [0, 18, 0, 32, 3, 51, 51, 53, 48, 6, 0, 34, 0, 32, 6], + [32, 2, 0, 32, 6, 32, 2, 0, 51, 53, 48, 21, 51, 53, 1], + [48, 20, 51, 121, 0, 18, 64, 8, 144, 1, 16, 0, 4, 16, 1], + [168, 3, 0, 64, 3, 144, 1, 0, 49, 0, 16, 3, 0, 40, 144], + [3, 9, 0, 0, 9, 0, 0, 9, 0, 9, 0, 16, 1, 0, 16], + [1, 0, 24, 2, 128, 49, 0, 16, 0, 144, 1, 0, 16, 1, 0], + [16, 1, 152, 2, 0, 56, 3, 16, 0, 144, 1, 0, 16, 1, 0], + [16, 1, 128, 24, 3, 16, 0, 144, 1, 0, 16, 1, 0, 16, 1], + [128, 16, 3, 16, 0, 144, 1, 0, 16, 1, 0, 16, 1, 128, 8], + [3, 16, 0, 0, 136, 144, 1, 0, 0, 16, 144, 1, 0, 9, 0], + [16, 1, 152, 0, 128, 32, 1, 137, 0, 0, 8, 137, 0, 16, 0], + [144, 1, 152, 0, 128, 24, 1, 8, 144, 0, 0, 137, 0, 0, 9], + [0, 16, 1, 144, 1, 153, 171, 212, 0, 64, 24, 1, 76, 221, 32], + [4, 0, 34, 64, 4, 0, 0, 66, 64, 4, 0, 0, 36, 0, 0], + [33] + ] + +{- Preproceesed Plutus Script +evenRedeemer2'_0 :: PlutusTx.Data.Data -> PlutusTx.Data.Data -> () +evenRedeemer2'_0 (PlutusTx.Data.I n_1) _d3_2 = if PlutusTx.Prelude.modulo n_1 2 PlutusTx.Eq.== 0 + then GHC.Tuple.() + else PlutusTx.Prelude.error GHC.Tuple.() +-} + +evenRedeemer2 :: Script era +evenRedeemer2 = + (PlutusScript . pack . concat) + [ [88, 254, 1, 0, 0, 51, 50, 0, 32, 2, 0, 50, 0, 50, 0], + [51, 32, 2, 0, 51, 50, 0, 32, 2, 0, 51, 51, 51, 32, 2], + [0, 32, 2, 0, 32, 2, 0, 51, 32, 2, 0, 50, 0, 50, 0], + [0, 18, 0, 32, 3, 51, 51, 53, 48, 6, 0, 34, 0, 32, 6], + [32, 2, 0, 32, 6, 32, 2, 0, 51, 53, 48, 21, 51, 53, 1], + [48, 20, 51, 121, 0, 18, 64, 8, 144, 0, 16, 0, 4, 16, 1], + [168, 3, 0, 64, 3, 144, 1, 0, 49, 0, 16, 3, 0, 40, 144], + [3, 9, 0, 0, 9, 0, 0, 9, 0, 9, 0, 16, 1, 0, 16], + [1, 0, 24, 2, 128, 49, 0, 16, 0, 144, 1, 0, 16, 1, 0], + [16, 1, 152, 2, 0, 56, 3, 16, 0, 144, 1, 0, 16, 1, 0], + [16, 1, 128, 24, 3, 16, 0, 144, 1, 0, 16, 1, 0, 16, 1], + [128, 16, 3, 16, 0, 144, 1, 0, 16, 1, 0, 16, 1, 128, 8], + [3, 16, 0, 0, 136, 144, 1, 0, 0, 16, 144, 1, 0, 9, 0], + [16, 1, 152, 0, 128, 32, 1, 137, 0, 0, 8, 137, 0, 16, 0], + [144, 1, 152, 0, 128, 24, 1, 8, 144, 0, 0, 137, 0, 0, 9], + [0, 16, 1, 144, 1, 153, 171, 212, 0, 64, 24, 1, 76, 221, 32], + [4, 0, 34, 64, 4, 0, 0, 66, 64, 4, 0, 0, 36, 0, 0], + [33] + ] + +{- Preproceesed Plutus Script +redeemerIs102'_0 :: PlutusTx.Data.Data -> PlutusTx.Data.Data -> () +redeemerIs102'_0 (PlutusTx.Data.I n_1) _d3_2 = if n_1 PlutusTx.Eq.== 10 + then GHC.Tuple.() + else PlutusTx.Prelude.error GHC.Tuple.() +-} + +redeemerIs102 :: Script era +redeemerIs102 = + (PlutusScript . pack . concat) + [ [88, 250, 1, 0, 0, 51, 50, 0, 32, 2, 0, 50, 0, 50, 0], + [51, 32, 2, 0, 51, 50, 0, 32, 2, 0, 51, 51, 51, 32, 2], + [0, 32, 2, 0, 32, 2, 0, 51, 32, 2, 0, 50, 0, 50, 0], + [0, 18, 0, 32, 3, 51, 51, 53, 48, 6, 0, 34, 0, 32, 6], + [32, 2, 0, 32, 6, 32, 2, 0, 51, 53, 48, 21, 51, 53, 1], + [48, 20, 0, 36, 128, 80, 128, 0, 32, 128, 13, 64, 24, 2, 0], + [28, 128, 8, 1, 136, 0, 128, 24, 1, 68, 128, 24, 72, 0, 0], + [72, 0, 0, 72, 0, 72, 0, 128, 8, 0, 128, 8, 0, 192, 20], + [1, 136, 0, 128, 4, 128, 8, 0, 128, 8, 0, 128, 12, 192, 16], + [1, 192, 24, 128, 4, 128, 8, 0, 128, 8, 0, 128, 12, 0, 192], + [24, 128, 4, 128, 8, 0, 128, 8, 0, 128, 12, 0, 128, 24, 128], + [4, 128, 8, 0, 128, 8, 0, 128, 12, 0, 64, 24, 128, 0, 4], + [68, 128, 8, 0, 0, 132, 128, 8, 0, 72, 0, 128, 12, 192, 4], + [1, 0, 12, 72, 0, 0, 68, 72, 0, 128, 4, 128, 12, 192, 4], + [0, 192, 8, 68, 128, 0, 4, 72, 0, 0, 72, 0, 128, 12, 128], + [12, 205, 94, 160, 2, 0, 192, 10, 102, 233, 0, 32, 1, 18, 0], + [32, 0, 2, 18, 0, 32, 0, 1, 32, 0, 1, 1] + ] diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Golden.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Golden.hs index c7688fa1e0f..b99ab622e6d 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Golden.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Golden.hs @@ -15,9 +15,8 @@ import Cardano.Ledger.Alonzo.Rules.Utxo (utxoEntrySize) import Cardano.Ledger.Alonzo.TxBody (TxOut (..)) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Mary.Value (Value (..)) +import Cardano.Ledger.Mary.Value (valueFromList) import Data.Char (chr) -import qualified Data.Map.Strict as Map import Plutus.V1.Ledger.Api (Data (..)) import Test.Cardano.Ledger.EraBuffet (StandardCrypto) import Test.Cardano.Ledger.Mary.Golden @@ -52,9 +51,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut carlAddr - ( Value 1407406 $ - Map.singleton pid1 (Map.fromList [(smallestName, 1)]) - ) + (valueFromList 1407406 [(pid1, smallestName, 1)]) (SJust $ hashData @(AlonzoEra StandardCrypto) (Data (List []))) ) @?= Coin 1655136, @@ -62,9 +59,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut bobAddr - ( Value 1407406 $ - Map.singleton pid1 (Map.fromList [(smallestName, 1)]) - ) + (valueFromList 1407406 [(pid1, smallestName, 1)]) SNothing ) @?= Coin 1310316, @@ -72,11 +67,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut aliceAddr - ( Value 1444443 $ - Map.singleton - pid1 - (Map.fromList [(smallName '1', 1)]) - ) + (valueFromList 1444443 [(pid1, smallName '1', 1)]) SNothing ) @?= Coin 1344798, @@ -84,16 +75,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut aliceAddr - ( Value 1555554 $ - Map.singleton - pid1 - ( Map.fromList - [ (smallName '1', 1), - (smallName '2', 1), - (smallName '3', 1) - ] - ) - ) + (valueFromList 1555554 [(pid1, smallName '1', 1), (pid1, smallName '2', 1), (pid1, smallName '3', 1)]) SNothing ) @?= Coin 1448244, @@ -101,11 +83,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut carlAddr - ( Value 1555554 $ - Map.singleton - pid1 - (Map.fromList [(largestName 'a', 1)]) - ) + (valueFromList 1555554 [(pid1, largestName 'a', 1)]) SNothing ) @?= Coin 1448244, @@ -113,15 +91,12 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut carlAddr - ( Value 1962961 $ - Map.singleton - pid1 - ( Map.fromList - [ (largestName 'a', 1), - (largestName 'b', 1), - (largestName 'c', 1) - ] - ) + ( valueFromList + 1962961 + [ (pid1, largestName 'a', 1), + (pid1, largestName 'b', 1), + (pid1, largestName 'c', 1) + ] ) (SJust $ hashData @(AlonzoEra StandardCrypto) (Data (Constr 0 [(Constr 0 [])]))) ) @@ -130,16 +105,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut aliceAddr - ( Value 1592591 $ - Map.fromList - [ ( pid1, - (Map.fromList [(smallestName, 1)]) - ), - ( pid2, - (Map.fromList [(smallestName, 1)]) - ) - ] - ) + (valueFromList 1592591 [(pid1, smallestName, 1), (pid2, smallestName, 1)]) SNothing ) @?= Coin 1482726, @@ -147,16 +113,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut aliceAddr - ( Value 1592591 $ - Map.fromList - [ ( pid1, - (Map.fromList [(smallestName, 1)]) - ), - ( pid2, - (Map.fromList [(smallestName, 1)]) - ) - ] - ) + (valueFromList 1592591 [(pid1, smallestName, 1), (pid2, smallestName, 1)]) (SJust $ hashData @(AlonzoEra StandardCrypto) (Data (Constr 0 []))) ) @?= Coin 1827546, @@ -164,16 +121,7 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut bobAddr - ( Value 1629628 $ - Map.fromList - [ ( pid1, - (Map.fromList [(smallName '1', 1)]) - ), - ( pid2, - (Map.fromList [(smallName '2', 1)]) - ) - ] - ) + (valueFromList 1629628 [(pid1, smallName '1', 1), (pid2, smallName '2', 1)]) SNothing ) @?= Coin 1517208, @@ -181,19 +129,24 @@ goldenUTxOEntryMinAda = calcMinUTxO ( TxOut aliceAddr - ( Value 7407400 $ - Map.fromList - [ ( pid1, - (Map.fromList $ map ((,1) . smallName . chr) [32 .. 63]) - ), - ( pid2, - (Map.fromList $ map ((,1) . smallName . chr) [64 .. 95]) - ), - ( pid3, - (Map.fromList $ map ((,1) . smallName . chr) [96 .. 127]) - ) - ] + ( let f i c = (i, smallName (chr c), 1) + in valueFromList 7407400 [f i c | (i, cs) <- [(pid1, [32 .. 63]), (pid2, [64 .. 95]), (pid3, [96 .. 127])], c <- cs] ) + {- + ( Value 7407400 $ + Map.fromList + [ ( pid1, + (Map.fromList $ map ((,1) . smallName . chr) [32 .. 63]) + ), + ( pid2, + (Map.fromList $ map ((,1) . smallName . chr) [64 .. 95]) + ), + ( pid3, + (Map.fromList $ map ((,1) . smallName . chr) [96 .. 127]) + ) + ] + ) + -} SNothing ) @?= Coin 6896400 diff --git a/cardano-ledger-test/benchProperty/Main.hs b/cardano-ledger-test/benchProperty/Main.hs new file mode 100644 index 00000000000..2ab9fed4f6e --- /dev/null +++ b/cardano-ledger-test/benchProperty/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +-- Embed instances for (AlonzoEra TestCrypto) +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This benchmark file is for profiling Property tests. It appears as a benchmark +-- but we do not use any of the criterion stuff. We just run main, which is profiled. +-- First set up the cabal.project.local (in the root of the cardano-ledger-specs directory) as follows. +-- ---- +-- ignore-project: False +-- profiling: True +-- profiling-detail: all-functions +-- package plutus-core +-- ghc-options: -fexternal-interpreter +-- --- +-- In the cardano-ledger-test directory (where the cardano-ledger-test.cabal file resides) +-- This cabal file defines the benchProperty benchmark. Now build with profiling enabled +-- cabal build benchProperty --enable-profiling +-- Now run the build with the -- +RTS -p flags +-- cabal run benchProperty -- +RTS -p +-- +-- When you are done be sure an reset the cabal.project.local, and rebuild things +-- without profiling enabled. One way to do this is +-- Reset the cabal.project.local file +-- cabal configure +-- Rebuild everything in the current project +-- cabal build +module Main where + +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.PParams (PParams' (..)) +import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBBODY) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoUTXOW) +import Control.State.Transition.Extended (Embed (..)) +import Shelley.Spec.Ledger.STS.Chain (CHAIN, ChainPredicateFailure (..)) +import Shelley.Spec.Ledger.STS.Ledger (LEDGER, LedgerPredicateFailure (UtxowFailure)) +import Test.Cardano.Ledger.Alonzo.AlonzoEraGen () +import Test.Cardano.Ledger.EraBuffet (TestCrypto) +import Test.Shelley.Spec.Ledger.Rules.ClassifyTraces (relevantCasesAreCovered) +import qualified Test.Tasty as T +import Test.Tasty.QuickCheck + +instance Embed (AlonzoBBODY (AlonzoEra TestCrypto)) (CHAIN (AlonzoEra TestCrypto)) where + wrapFailed = BbodyFailure + +instance Embed (AlonzoUTXOW (AlonzoEra TestCrypto)) (LEDGER (AlonzoEra TestCrypto)) where + wrapFailed = UtxowFailure + +profileCover :: IO () +profileCover = + T.defaultMain $ + testProperty + "Chain and Ledger traces cover the relevant cases" + (withMaxSuccess 1 (relevantCasesAreCovered @(AlonzoEra TestCrypto))) + +main :: IO () +main = profileCover diff --git a/cardano-ledger-test/cardano-ledger-test.cabal b/cardano-ledger-test/cardano-ledger-test.cabal index 1c3885b9fc3..363ad0e355d 100644 --- a/cardano-ledger-test/cardano-ledger-test.cabal +++ b/cardano-ledger-test/cardano-ledger-test.cabal @@ -89,7 +89,9 @@ benchmark bench bytestring, cardano-binary, cardano-crypto-class, + cardano-ledger-alonzo, cardano-ledger-core, + cardano-ledger-alonzo-test, cardano-ledger-shelley-ma-test, cardano-ledger-shelley-ma, containers, @@ -97,8 +99,35 @@ benchmark bench data-default-class, deepseq, QuickCheck, + small-steps, + shelley-spec-ledger, + shelley-spec-ledger-test, + tasty-quickcheck, + tasty + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + -O2 + +benchmark benchProperty + import: base, project-config + + type: exitcode-stdio-1.0 + hs-source-dirs: + benchProperty + main-is: Main.hs + other-modules: + build-depends: + cardano-ledger-alonzo, + cardano-ledger-alonzo-test, + cardano-ledger-shelley-ma-test, + QuickCheck, + small-steps, shelley-spec-ledger, - shelley-spec-ledger-test + shelley-spec-ledger-test, + tasty-quickcheck, + tasty ghc-options: -threaded -rtsopts diff --git a/nix/haskell.nix b/nix/haskell.nix index a9cea480924..aaf5cb58c18 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -29,6 +29,7 @@ let compiler-nix-name = compiler; modules = [ { + packages.plutus-core.components.library.ghcOptions = [ "-fexternal-interpreter" ]; packages.byron-spec-chain.configureFlags = [ "--ghc-option=-Werror" ]; packages.byron-spec-ledger.configureFlags = [ "--ghc-option=-Werror" ]; packages.delegation.configureFlags = [ "--ghc-option=-Werror" ]; diff --git a/plutus-preprocessor/src/Main.hs b/plutus-preprocessor/src/Main.hs index f95b227d8b0..a3153f33568 100644 --- a/plutus-preprocessor/src/Main.hs +++ b/plutus-preprocessor/src/Main.hs @@ -30,6 +30,9 @@ import PlutusScripts odddataDecl, oddRedeemerDecl, sumsTo10Decl, + evenRedeemerDecl2Args, + oddRedeemerDecl2Args, + redeemerIs10Decl2Args ) import System.IO @@ -66,6 +69,9 @@ $evenRedeemerDecl $odddataDecl $oddRedeemerDecl $sumsTo10Decl +$evenRedeemerDecl2Args +$oddRedeemerDecl2Args +$redeemerIs10Decl2Args -- ================================================================ -- Compile the real functions as Plutus scripts, and get their @@ -107,6 +113,21 @@ sumsTo10Bytes = toShort . toStrict . serialise . P.fromCompiledCode $ $$(P.compile [||sumsTo10'||]) +oddRedeemerBytes2Arg :: ShortByteString +oddRedeemerBytes2Arg = + toShort . toStrict . serialise . P.fromCompiledCode $ + $$(P.compile [||oddRedeemer2'||]) + +evenRedeemerBytes2Args :: ShortByteString +evenRedeemerBytes2Args = + toShort . toStrict . serialise . P.fromCompiledCode $ + $$(P.compile [||evenRedeemer2'||]) + +redeemerIs10Bytes2Args :: ShortByteString +redeemerIs10Bytes2Args = + toShort . toStrict . serialise . P.fromCompiledCode $ + $$(P.compile [||redeemerIs102'||]) + -- ======================================================================== -- Generate the PlutusScripts.hs which does not depend on plutus-plugin. -- write out the file header (module and imports), then 'display' the result @@ -128,4 +149,8 @@ main = do display outh evenRedeemerBytes evenRedeemerDecl "evenRedeemer3" display outh oddRedeemerBytes oddRedeemerDecl "oddRedeemer3" display outh sumsTo10Bytes sumsTo10Decl "sumsTo103" + -- 2 arg plutus scripts + display outh oddRedeemerBytes2Arg oddRedeemerDecl2Args "oddRedeemer2" + display outh evenRedeemerBytes2Args evenRedeemerDecl2Args "evenRedeemer2" + display outh redeemerIs10Bytes2Args redeemerIs10Decl2Args "redeemerIs102" hClose outh diff --git a/plutus-preprocessor/src/PlutusScripts.hs b/plutus-preprocessor/src/PlutusScripts.hs index 2d6de8a781d..b1a758b1bcd 100644 --- a/plutus-preprocessor/src/PlutusScripts.hs +++ b/plutus-preprocessor/src/PlutusScripts.hs @@ -9,6 +9,9 @@ module PlutusScripts odddataDecl, oddRedeemerDecl, sumsTo10Decl, + evenRedeemerDecl2Args, + oddRedeemerDecl2Args, + redeemerIs10Decl2Args, ) where import qualified Plutus.V1.Ledger.Scripts as P @@ -58,3 +61,25 @@ sumsTo10Decl = [d| sumsTo10' :: P.Data -> P.Data -> P.Data -> () sumsTo10' (P.I m) (P.I n)_d3 = if (m P.+ n) P.== 10 then () else (P.error ()) |] + +-- =========================== +-- 2 arg Plutus scripts, for use in non payment contexts + + +oddRedeemerDecl2Args :: Q [Dec] +oddRedeemerDecl2Args = + [d| oddRedeemer2' :: P.Data -> P.Data -> () + oddRedeemer2' (P.I n)_d3 = if (P.modulo n 2) P.== 1 then () else (P.error ()) + |] + +evenRedeemerDecl2Args :: Q [Dec] +evenRedeemerDecl2Args = + [d| evenRedeemer2' :: P.Data -> P.Data -> () + evenRedeemer2' (P.I n) _d3 = if (P.modulo n 2) P.== 0 then () else (P.error ()) + |] + +redeemerIs10Decl2Args :: Q [Dec] +redeemerIs10Decl2Args = + [d| redeemerIs102' :: P.Data -> P.Data -> () + redeemerIs102' (P.I n) _d3 = if n P.== 10 then () else (P.error ()) + |] diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs index 0d3fbba9ecb..e05aea2d013 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs @@ -43,7 +43,7 @@ import qualified Cardano.Crypto.Hash.Class as Hash import Cardano.Ledger.Coin (Coin (..), integerToWord64) import Cardano.Ledger.Compactible (Compactible (..)) import qualified Cardano.Ledger.Crypto as CC -import Cardano.Ledger.Pretty (PDoc, PrettyA (..), ppCoin, ppInteger, ppList, ppLong, ppScriptHash, ppSexp) +import Cardano.Ledger.Pretty (PDoc, PrettyA (..), ppCoin, ppInteger, ppList, ppLong, ppScriptHash, ppSexp, ppString) import Cardano.Ledger.Serialization (decodeMap, encodeMap) import Cardano.Ledger.Val ( DecodeMint (..), @@ -769,22 +769,28 @@ showValue v = show c ++ "\n" ++ unlines (map trans ts) -- | Turn the nested 'Value' map-of-maps representation into a flat sequence -- of policyID, asset name and quantity, plus separately the ada quantity. -gettriples :: Value crypto -> (Integer, [(PolicyID crypto, AssetName, Integer)]) -gettriples (Value c m1) = (c, triples) +gettriples' :: Value crypto -> (Integer, [(PolicyID crypto, AssetName, Integer)], [PolicyID crypto]) +gettriples' (Value c m1) = (c, triples, bad) where triples = [ (policyId, aname, amount) | (policyId, m2) <- assocs m1, (aname, amount) <- assocs m2 ] + bad = Map.keys (Map.filter Map.null m1) -- This is a malformed value, not in cannonical form. + +gettriples :: Value crypto -> (Integer, [(PolicyID crypto, AssetName, Integer)]) +gettriples v = case gettriples' v of + (a, b, _) -> (a, b) -- ===================================== -- Pretty printing functions ppValue :: Value crypto -> PDoc -ppValue v = ppSexp "Value" [ppCoin (Coin n), ppList pptriple triples] +ppValue v = case gettriples' v of + (n, triples, []) -> ppSexp "Value" [ppCoin (Coin n), ppList pptriple triples] + (n, triples, bad) -> ppSexp "Value" [ppCoin (Coin n), ppList pptriple triples, ppString "Bad " <> ppList ppPolicyID bad] where - (n, triples) = gettriples v pptriple (i, asset, num) = hsep [ppPolicyID i, ppAssetName asset, ppInteger num] ppPolicyID :: PolicyID crypto -> PDoc diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs index 3260980368c..d5f6017acf8 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.Mary.Value PolicyID (..), Value (..), policies, + valueFromList, ) import Cardano.Ledger.ShelleyMA.Rules.Utxo (scaledMinDeposit) import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) @@ -151,7 +152,7 @@ red = AssetName $ BS.pack "redCoin" genRed :: CryptoClass.Crypto c => Gen (Value c) genRed = do n <- genInteger coloredCoinMinMint coloredCoinMaxMint - pure $ Value 0 (Map.singleton redCoinId (Map.singleton red n)) + pure $ valueFromList 0 [(redCoinId,red,n)] -------------------------------------------------------- -- Blue Coins -- @@ -177,7 +178,7 @@ genBlue :: CryptoClass.Crypto c => Gen (Value c) genBlue = do as <- QC.resize maxBlueMint $ QC.listOf genSingleBlue -- the transaction size gets too big if we mint too many assets - pure $ Value 0 (Map.singleton blueCoinId (Map.fromList as)) + pure $ valueFromList 0 (map (\ (asset,count) -> (blueCoinId,asset,count)) as) where genSingleBlue = do n <- genInteger coloredCoinMinMint coloredCoinMaxMint @@ -204,7 +205,7 @@ genYellow :: CryptoClass.Crypto c => Gen (Value c) genYellow = do xs <- QC.sublistOf [0 .. yellowNumAssets] as <- mapM genSingleYellow xs - pure $ Value 0 (Map.singleton yellowCoinId (Map.fromList as)) + pure $ valueFromList 0 (map (\ (asset,count) -> (yellowCoinId,asset,count)) as) where genSingleYellow x = do y <- genInteger coloredCoinMinMint coloredCoinMaxMint 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 34bbd883982..e39ab6a9efa 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 @@ -78,7 +78,7 @@ genChainState n ge = -- unimportant for now, we set the A part of the fee to 0 maxMinFeeA = 0 } - ge' = GenEnv (geKeySpace ge) (ScriptSpace [] Map.empty) cs + ge' = GenEnv (geKeySpace ge) (ScriptSpace [] [] Map.empty Map.empty) cs in fromRight (error "genChainState failed") <$> ( generate $ mkGenesisChainState ge' (IRC ()) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs index f7de80f96cc..ecc3f21fce0 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Rewards.hs @@ -75,7 +75,7 @@ genChainInEpoch :: EpochNo -> Gen (ChainState B) genChainInEpoch epoch = do genesisChainState <- fromRight (error "genChainState failed") - <$> mkGenesisChainState @B (GenEnv ks (ScriptSpace [] Map.empty) cs) (IRC ()) + <$> mkGenesisChainState @B (GenEnv ks (ScriptSpace [] [] Map.empty Map.empty) cs) (IRC ()) -- Our genesis chain state contains no registered staking. Since we want to -- calculate a reward update, we will set some up. -- What do we want to do here? diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal index f45766b465f..0bf844ee04a 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal @@ -63,6 +63,7 @@ library Test.Shelley.Spec.Ledger.Generator.ScriptClass Test.Shelley.Spec.Ledger.Generator.ShelleyEraGen Test.Shelley.Spec.Ledger.Orphans + Test.Shelley.Spec.Ledger.Rules.ClassifyTraces Test.Shelley.Spec.Ledger.Serialisation.CDDLUtils Test.Shelley.Spec.Ledger.Serialisation.Generators Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators @@ -79,7 +80,6 @@ library Test.Shelley.Spec.Ledger.Address.CompactAddr Test.Shelley.Spec.Ledger.ByronTranslation Test.Shelley.Spec.Ledger.Examples.Federation - Test.Shelley.Spec.Ledger.Rules.ClassifyTraces Test.Shelley.Spec.Ledger.Rules.TestDeleg Test.Shelley.Spec.Ledger.Rules.TestPool Test.Shelley.Spec.Ledger.Rules.TestPoolreap @@ -103,6 +103,7 @@ library data-default-class, directory, generic-random, + hashable, hedgehog-quickcheck, hedgehog >= 1.0.4, iproute, 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 9f674a72174..937c171492b 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 @@ -16,7 +16,8 @@ module Test.Shelley.Spec.Ledger.Generator.Core applyTxBody, GenEnv (..), ScriptSpace(..), - TwoPhaseInfo(..), + TwoPhase3ArgInfo(..), + TwoPhase2ArgInfo(..), ScriptInfo, KeySpace (..), pattern KeySpace, @@ -53,7 +54,6 @@ module Test.Shelley.Spec.Ledger.Generator.Core genCoin, PreAlonzo, hashData, - genPlutus, findPlutus, ) where @@ -184,7 +184,7 @@ import Shelley.Spec.Ledger.UTxO pattern UTxO, ) import Test.Cardano.Crypto.VRF.Fake (WithResult (..)) -import Test.QuickCheck (Gen,oneof) +import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (ExMock, Mock) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) @@ -238,24 +238,38 @@ data AllIssuerKeys v (r :: KeyRole) = AllIssuerKeys deriving (Show) type DataHash crypto = SafeHash crypto EraIndependentData -type ScriptInfo era = Map (ScriptHash (Crypto era)) (TwoPhaseInfo era) +type ScriptInfo era = (Map (ScriptHash (Crypto era)) (TwoPhase3ArgInfo era), + Map (ScriptHash (Crypto era)) (TwoPhase2ArgInfo era)) + +data TwoPhase3ArgInfo era = TwoPhase3ArgInfo + { getScript3 :: Core.Script era, -- ^ A Plutus Script + getHash3 :: ScriptHash (Crypto era), -- ^ Its ScriptHash + getData3 :: Plutus.Data, -- ^ A Data that will make it succeed + getRedeemer3 :: + ( Plutus.Data, -- The redeeming data + Word64, -- The ExUnits memory count + Word64 -- The ExUnits steps count + ) -- ^ A Redeemer that will make it succeed + } -data TwoPhaseInfo era = TwoPhaseInfo - { getScript :: Core.Script era, -- ^ A Plutus Script - getHash :: ScriptHash (Crypto era), -- ^ Its ScriptHash - getData :: Plutus.Data, -- ^ A Data that will make it succeed - getRedeemer :: +data TwoPhase2ArgInfo era = TwoPhase2ArgInfo + { getScript2 :: Core.Script era, -- ^ A Plutus Script + getHash2 :: ScriptHash (Crypto era), -- ^ Its ScriptHash + getRedeemer2 :: ( Plutus.Data, -- The redeeming data Word64, -- The ExUnits memory count Word64 -- The ExUnits steps count ) -- ^ A Redeemer that will make it succeed } -deriving instance Show (Core.Script era) => Show (TwoPhaseInfo era) +deriving instance Show (Core.Script era) => Show (TwoPhase3ArgInfo era) +deriving instance Show (Core.Script era) => Show (TwoPhase2ArgInfo era) data ScriptSpace era = ScriptSpace - { ssScripts :: [TwoPhaseInfo era], -- ^ A list of Two Phase Scripts and their associated data we can use. - ssHash :: Map (ScriptHash (Crypto era)) (TwoPhaseInfo era) -- ^ Also called (ScriptInfo era) + { ssScripts3 :: [TwoPhase3ArgInfo era], -- ^ A list of Two Phase 3 Arg Scripts and their associated data we can use. + ssScripts2 :: [TwoPhase2ArgInfo era], -- ^ A list of Two Phase 2 Arg Scripts and their associated data we can use. + ssHash3 :: Map (ScriptHash (Crypto era)) (TwoPhase3ArgInfo era), + ssHash2 :: Map (ScriptHash (Crypto era)) (TwoPhase2ArgInfo era) } deriving instance Show (Core.Script era) => Show (ScriptSpace era) @@ -757,20 +771,24 @@ applyTxBody ls pp tx = hashData :: forall era. Era era => Plutus.Data -> DataHash (Crypto era) hashData x = unsafeMakeSafeHash (Hash.castHash (Hash.hashWith (toStrict . serialise) x)) +{- -- | Choose one of the preallocated PlutusScripts, and return it and its Hash genPlutus :: forall era. GenEnv era -> Gen(Core.Script era,ScriptHash (Crypto era),TwoPhaseInfo era) genPlutus (GenEnv _ (ScriptSpace scripts _) _) = gettriple <$> oneof (pure <$> scripts) where gettriple (info@(TwoPhaseInfo script hash _data _rdmr)) = (script,hash,info) +-} -- | Find the preallocated Script from its Hash. findPlutus :: forall era. Era era => GenEnv era -> (ScriptHash (Crypto era)) -> (Core.Script era, StrictMaybe (DataHash (Crypto era))) -findPlutus (GenEnv keyspace (ScriptSpace _ mp) _) hsh = - case Map.lookup hsh mp of - Just info -> (getScript info, SJust (hashData @era (getData info))) +findPlutus (GenEnv keyspace (ScriptSpace _ _ mp3 mp2) _) hsh = + case Map.lookup hsh mp3 of + Just info3 -> (getScript3 info3, SJust (hashData @era (getData3 info3))) Nothing -> - case Map.lookup hsh (ksIndexedPayScripts keyspace) of - Just (pay,_stake) -> (pay, SNothing) - Nothing -> - case Map.lookup hsh (ksIndexedStakeScripts keyspace) of - Just(_pay,stake) -> (stake, SNothing) - Nothing -> error ("Can't find a Script for the hash: "++show hsh) + case Map.lookup hsh mp2 of + Just info2 -> (getScript2 info2, SNothing) + Nothing -> case Map.lookup hsh (ksIndexedPayScripts keyspace) of + Just (pay,_stake) -> (pay, SNothing) + Nothing -> + case Map.lookup hsh (ksIndexedStakeScripts keyspace) of + Just(_pay,stake) -> (stake, SNothing) + Nothing -> error ("Can't find a Script for the hash: "++show hsh) 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 21b2119a363..a79b66df848 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 @@ -28,9 +28,10 @@ module Test.Shelley.Spec.Ledger.Generator.EraGen Sets(..), someKeyPairs, allScripts, + randomByHash, ) where -import Cardano.Binary (ToCBOR (toCBOR),FromCBOR,Annotator) +import Cardano.Binary (ToCBOR (toCBOR),serializeEncoding', FromCBOR,Annotator) import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Coin (Coin(..)) @@ -43,6 +44,7 @@ import Cardano.Ledger.Shelley.Constraints (UsesPParams(..)) import Shelley.Spec.Ledger.PParams(Update) import Cardano.Slotting.Slot (SlotNo) import Data.Coerce (coerce) +import Data.Hashable (Hashable (..)) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import Data.Default.Class(Default) @@ -62,7 +64,8 @@ import Test.QuickCheck (Gen,shuffle,choose) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) import Test.Shelley.Spec.Ledger.Generator.Core ( GenEnv (..), - TwoPhaseInfo(..), + TwoPhase3ArgInfo(..), + TwoPhase2ArgInfo(..), ScriptInfo, genesisCoins, ) @@ -222,9 +225,13 @@ class -- | Generate a genesis value for the Era genGenesisValue :: GenEnv era -> Gen (Core.Value era) - -- | A list of two-phase scripts that can be chosen when building a transaction - genEraTwoPhaseScripts :: [ TwoPhaseInfo era] - genEraTwoPhaseScripts = [] + -- | A list of two-phase scripts that can be chosen for payment when building a transaction + genEraTwoPhase3Arg:: [ TwoPhase3ArgInfo era] + genEraTwoPhase3Arg = [] + +-- | A list of two-phase scripts that can be chosen for Delegating, Minting, or Rewarding when building a transaction + genEraTwoPhase2Arg:: [ TwoPhase2ArgInfo era] + genEraTwoPhase2Arg = [] -- | Given some pre-generated data, generate an era-specific TxBody, -- and a list of additional scripts for eras that sometimes require @@ -349,12 +356,42 @@ someScripts :: Gen [(Core.Script era, Core.Script era)] someScripts c lower upper = take <$> choose (lower, upper) <*> shuffle (allScripts @era c) +-- | A list of all possible kinds of scripts in the current Era. +-- Might include Keylocked scripts, Start-Finish Timelock scripts, Quantified scripts (All, Any, MofN), Plutus Scripts +-- Note that 'genEraTwoPhase3Arg' and 'genEraTwoPhase2Arg' may be the empty list ([]) in some Eras. allScripts:: forall era. EraGen era => Constants -> [(Core.Script era, Core.Script era)] -allScripts c = (zipWith combine genEraTwoPhaseScripts (baseScripts @era c) ++ combinedScripts @era c) - where -- make pairs of scripts (payment,staking) where the payment part is a PlutusScript - combine :: TwoPhaseInfo era -> (Core.Script era, Core.Script era) -> (Core.Script era, Core.Script era) - combine info (_,stake) = (getScript info,stake) - +allScripts c = (plutusPairs genEraTwoPhase3Arg genEraTwoPhase2Arg (take 3 simple)) ++ -- 10 means about 5% of allScripts are Plutus Scripts + -- Plutus scripts in some Eras ([] in other Eras) + -- [(payment,staking)] where the either payment or staking may be a plutus script + (take (numSimpleScripts c) simple) ++ + -- Simple scripts (key locked, Start-Finish timelocks) + (combinedScripts @era c) + -- Quantifed scripts (All, Any, MofN) + where + simple = baseScripts @era c + plutusPairs :: [TwoPhase3ArgInfo era] -> [TwoPhase2ArgInfo era] -> [(Core.Script era, Core.Script era)] -> [(Core.Script era, Core.Script era)] + plutusPairs []_ _ = [] + plutusPairs _ [] _ = [] + plutusPairs _ _ [] = [] + plutusPairs args3 args2 ((pay,stake):more) = pair : plutusPairs args3 args2 more + where count3 = length args3 - 1 + count2 = length args2 - 1 + n = randomByHash 0 count3 stake + m = randomByHash 0 count2 pay + mode = randomByHash 1 3 pay + pair = case mode of + 1 -> (getScript3 (args3 !! n),stake) + 2 -> (pay, getScript2 (args2 !! m)) + 3 -> (getScript3 (args3 !! n),getScript2 (args2 !! m)) + i -> error ("mod function returns value out of bounds: "++show i) + +randomByHash :: forall x. ToCBOR x => Int -> Int -> x -> Int +randomByHash low high x = low + remainder + where n = hash (serializeEncoding' (toCBOR x)) + -- We don't really care about the hash, we only + -- use it to pseudo-randomly pick a number bewteen low and high + m = high - low + 1 + remainder = mod n m -- mode==0 is a time leaf, mode 1 or 2 is a signature leaf -- ========================================================= diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Presets.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Presets.hs index bd804f376dd..a8a2a82397d 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Presets.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Presets.hs @@ -49,7 +49,7 @@ import Test.Shelley.Spec.Ledger.Utils slotsPerKESIteration, ) -import Test.Shelley.Spec.Ledger.Generator.EraGen(EraGen(genEraTwoPhaseScripts),allScripts,someKeyPairs) +import Test.Shelley.Spec.Ledger.Generator.EraGen(EraGen(..),allScripts,someKeyPairs) import Data.Proxy(Proxy(..)) import Cardano.Ledger.Era (ValidateScript(hashScript)) @@ -64,12 +64,16 @@ genEnv :: forall era. genEnv _ = GenEnv (keySpace defaultConstants) - (scriptSpace @era (genEraTwoPhaseScripts @era)) + (scriptSpace @era (genEraTwoPhase3Arg @era) (genEraTwoPhase2Arg @era)) defaultConstants -- | An Example Script space for use in Trace generators -scriptSpace :: forall era. ValidateScript era => [TwoPhaseInfo era] -> ScriptSpace era -scriptSpace scripts = ScriptSpace scripts (Map.fromList [(hashScript @era (getScript s),s) | s <- scripts]) +scriptSpace :: forall era. ValidateScript era => [TwoPhase3ArgInfo era] -> [TwoPhase2ArgInfo era] -> ScriptSpace era +scriptSpace scripts3 scripts2 = + ScriptSpace scripts3 + scripts2 + (Map.fromList [(hashScript @era (getScript3 s),s) | s <- scripts3]) + (Map.fromList [(hashScript @era (getScript2 s),s) | s <- scripts2]) -- | Example keyspace for use in generators keySpace :: 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 e1ff8dc8091..003b20cc1b6 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 @@ -146,6 +146,8 @@ scriptKeyCombinations prox script = case quantify prox script of Just hk -> [[hk]] Nothing -> [[]] +-- | Make a simple (non-combined, ie NO quantifer like All, Any, MofN, etc.) script. +-- 'basescript' is a method of ScriptClass, and is different for every Era. mkScriptFromKey :: forall era. (ScriptClass era) => KeyPair 'Witness (Crypto era) -> Core.Script era mkScriptFromKey = (basescript (Proxy :: Proxy era) . hashKey . vKey) @@ -224,6 +226,9 @@ mkScriptCombinations msigs = ) :: [(Core.Script era, Core.Script era)] +-- | Make list of script pairs (payment,staking). These are non-combined scripts +-- Ie NO quantifer like All, Any, MofN, etc.) scripts. +-- In post Shelley Eras, either Keylock or Require Start-Finish scripts. baseScripts :: forall era. ScriptClass era => @@ -231,6 +236,9 @@ baseScripts :: [(Core.Script era, Core.Script era)] baseScripts c = mkScripts @era (keyPairs c) +-- | Make a list of script pairs (payment,staking). Each of these are combined scripts. +-- I.e. All, Any, MofN, etc. These come from combining the the first N (numBaseScripts) baseScripts +-- When N==3, we get about 150 combined scripts. combinedScripts :: forall era. ScriptClass era => 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 4376c0bb853..feff7f87be6 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 @@ -18,6 +18,7 @@ module Test.Shelley.Spec.Ledger.Generator.Utxo showBalance, getNRandomPairs, encodedLen, + myDiscard, ) where @@ -115,6 +116,11 @@ import Test.Shelley.Spec.Ledger.Generator.Update (genUpdate) import Test.Shelley.Spec.Ledger.Utils (Split (..)) import Cardano.Ledger.Era(Era) import NoThunks.Class() -- Instances only +import Debug.Trace(trace) + + +myDiscard :: String -> a +myDiscard message = trace ("Discard: "++message) discard import Debug.Trace(trace) @@ -233,7 +239,7 @@ genTx let txWits = spendWits ++ wdrlWits ++ certWits ++ updateWits scripts = mkScriptWits @era spendScripts (certScripts ++ wdrlScripts) mkTxWits' txbody = - mkTxWits @era (utxo,txbody,ssHash scriptspace) ksIndexedPaymentKeys + mkTxWits @era (utxo,txbody,(ssHash3 scriptspace,ssHash2 scriptspace)) ksIndexedPaymentKeys ksIndexedStakingKeys txWits scripts (hashAnnotated txbody) ------------------------------------------------------------------------- -- SpendingBalance, Output Addresses (including some Pointer addresses) @@ -263,8 +269,7 @@ genTx -- Occasionally we have a transaction generated with insufficient inputs -- to cover the deposits. In this case we discard the test case. let enough = (length outputAddrs) <×> (getField @"_minUTxOValue" pparams) - !_ <- when (coin spendingBalance < coin enough) - (myDiscard ("not enough coin in outputs. needed: "++show enough++", available: "++show spendingBalance) discard) + !_ <- when (coin spendingBalance < coin enough) (myDiscard "No inputs left. Utxo.hs") ------------------------------------------------------------------------- -- Build a Draft Tx and repeatedly add to Delta until all fees are @@ -293,7 +298,7 @@ genTx scripts' = Map.fromList $ map (\s -> (hashScript @era s, s)) additionalScripts -- We add now repeatedly add inputs until the process converges. converge - (ssHash scriptspace) + (ssHash3 scriptspace, ssHash2 scriptspace) remainderCoin txWits (scripts `Map.union` scripts') @@ -446,9 +451,7 @@ genNextDelta -- If it does happen, It is NOT a test failure, but an inadequacy in the -- testing framework to generate almost-random transactions that always succeed every time. -- Experience suggests that this happens less than 1% of the time, and does not lead to backtracking. - - !_ <- when (null inputs) (myDiscard ("Can't generate a new input, the Utxo is empty") discard) - + !_ <- when (null inputs) (myDiscard "NoMoneyleft Utxo.hs") let newWits = mkTxWits @era (utxo, txBody, scriptinfo)