From d0b94281228dfa6c113d0aa618a981e71674dc45 Mon Sep 17 00:00:00 2001 From: TimSheard Date: Fri, 11 Feb 2022 17:23:56 -0800 Subject: [PATCH] Added generic (Era agnostic tests) in Test.Cardano.Ledger.Generic package Meant to someday replace Test.Cardano.Ledger.Properties Add many PrettyA instances for UTXOW UTXO UTXOS PPUP predicate failures. Cleaned up the broken Policy type. --- .../src/Cardano/Ledger/Pretty/Alonzo.hs | 10 +- .../cardano-ledger-test.cabal | 2 + .../src/Test/Cardano/Ledger/Alonzo/Tools.hs | 1 - .../Ledger/Examples/TwoPhaseValidation.hs | 89 +- .../src/Test/Cardano/Ledger/Generic/Fields.hs | 40 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 572 +++++++ .../Test/Cardano/Ledger/Generic/Properties.hs | 1406 +++++++++++++++++ .../Test/Cardano/Ledger/Generic/Updaters.hs | 343 ++-- libs/cardano-ledger-test/test/Tests.hs | 4 +- 9 files changed, 2204 insertions(+), 263 deletions(-) create mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs create mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Alonzo.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Alonzo.hs index a95681e5f57..a82d0f8d58a 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Alonzo.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Alonzo.hs @@ -222,11 +222,11 @@ ppTxWitness :: (Era era, PrettyA (Core.Script era)) => TxWitness era -> PDoc ppTxWitness (TxWitness' vk wb sc da (Redeemers rd)) = ppRecord "TxWitness" - [ ("txwitsVKey", ppSet ppWitVKey vk), - ("txwitsBoot", ppSet ppBootstrapWitness wb), - ("txscripts", ppMap ppScriptHash prettyA sc), - ("txdats", ppMap ppSafeHash ppData (unTxDats da)), - ("txrdmrs", ppMap ppRdmrPtr (ppPair ppData ppExUnits) rd) + [ ("keys", ppSet ppWitVKey vk), + ("bootstrap witnesses", ppSet ppBootstrapWitness wb), + ("scripts map", ppMap ppScriptHash prettyA sc), + ("Data map", ppMap ppSafeHash ppData (unTxDats da)), + ("Redeemer map", ppMap ppRdmrPtr (ppPair ppData ppExUnits) rd) ] instance diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal index 3f915687727..69924905b9d 100644 --- a/libs/cardano-ledger-test/cardano-ledger-test.cabal +++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal @@ -54,6 +54,8 @@ library Test.Cardano.Ledger.Generic.Proof Test.Cardano.Ledger.Generic.Scriptic Test.Cardano.Ledger.Generic.Updaters + Test.Cardano.Ledger.Generic.PrettyCore + Test.Cardano.Ledger.Generic.Properties Test.Cardano.Ledger.Model.API Test.Cardano.Ledger.Model.Acnt Test.Cardano.Ledger.Model.BaseTypes diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs index 82e4a1b1dbd..c973164d128 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs @@ -118,7 +118,6 @@ exampleTx :: Core.Tx A exampleTx = let pf = Alonzo Mock in newTx - override pf [ Body (validatingBody pf), WitnessesI diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs index c404fa78d55..7af3cdab992 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs @@ -213,12 +213,11 @@ someAddr pf = Addr Testnet pCred sCred someOutput :: Scriptic era => Proof era -> Core.TxOut era someOutput pf = - newTxOut override pf [Address $ someAddr pf, Amount (inject $ Coin 1000)] + newTxOut pf [Address $ someAddr pf, Amount (inject $ Coin 1000)] nonScriptOutWithDatum :: forall era. (Scriptic era) => Proof era -> Core.TxOut era nonScriptOutWithDatum pf = newTxOut - override pf [ Address (someAddr pf), Amount (inject $ Coin 1221), @@ -230,7 +229,7 @@ mkGenesisTxIn = TxIn genesisId . mkTxIxPartial collateralOutput :: Scriptic era => Proof era -> Core.TxOut era collateralOutput pf = - newTxOut override pf [Address $ someAddr pf, Amount (inject $ Coin 5)] + newTxOut pf [Address $ someAddr pf, Amount (inject $ Coin 5)] alwaysSucceedsHash :: forall era. @@ -263,14 +262,13 @@ timelockAddr pf = Addr Testnet pCred sCred timelockOut :: PostShelley era => Proof era -> Core.TxOut era timelockOut pf = - newTxOut override pf [Address $ timelockAddr pf, Amount (inject $ Coin 1)] + newTxOut pf [Address $ timelockAddr pf, Amount (inject $ Coin 1)] -- | This output is unspendable since it is locked by a plutus script, -- but has no datum hash. unspendableOut :: forall era. (Scriptic era) => Proof era -> Core.TxOut era unspendableOut pf = newTxOut - override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 5000) @@ -350,7 +348,6 @@ txDatsExample1 = TxDats $ keyBy hashData $ [datumExample1] alwaysSucceedsOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysSucceedsOutput pf = newTxOut - override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 5000), @@ -360,7 +357,6 @@ alwaysSucceedsOutput pf = alwaysSucceedsOutputV2 :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysSucceedsOutputV2 pf = newTxOut - override pf [ Address (scriptAddr (alwaysAlt 3 pf) pf), Amount (inject $ Coin 5000), @@ -380,7 +376,6 @@ extraRedeemersEx = extraRedeemersBody :: Scriptic era => Proof era -> Core.TxBody era extraRedeemersBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -398,7 +393,6 @@ extraRedeemersTx :: Core.Tx era extraRedeemersTx pf = newTx - override pf [ Body (extraRedeemersBody pf), WitnessesI @@ -410,12 +404,11 @@ extraRedeemersTx pf = ] outEx1 :: Scriptic era => Proof era -> Core.TxOut era -outEx1 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 4995)] +outEx1 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 4995)] validatingBody :: Scriptic era => Proof era -> Core.TxBody era validatingBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -439,7 +432,6 @@ validatingTx :: Core.Tx era validatingTx pf = newTx - override pf [ Body (validatingBody pf), WitnessesI @@ -486,7 +478,6 @@ notValidatingRedeemers = alwaysFailsOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysFailsOutput pf = newTxOut - override pf [ Address (scriptAddr (never 0 pf) pf), Amount (inject $ Coin 3000), @@ -494,12 +485,11 @@ alwaysFailsOutput pf = ] outEx2 :: (Scriptic era) => Proof era -> Core.TxOut era -outEx2 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 2995)] +outEx2 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 2995)] notValidatingBody :: Scriptic era => Proof era -> Core.TxBody era notValidatingBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 2], Collateral' [mkGenesisTxIn 12], @@ -516,7 +506,6 @@ notValidatingTx :: Core.Tx era notValidatingTx pf = newTx - override pf [ Body (notValidatingBody pf), WitnessesI @@ -541,7 +530,7 @@ utxoStEx2 pf = smartUTxOState (utxoEx2 pf) (Coin 0) (Coin 5) def -- ========================================================================= outEx3 :: Era era => Proof era -> Core.TxOut era -outEx3 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 995)] +outEx3 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 995)] redeemerExample3 :: Data era redeemerExample3 = Data (Plutus.I 42) @@ -557,7 +546,6 @@ scriptStakeCredSuceed pf = ScriptHashObj (alwaysSucceedsHash 2 pf) validatingBodyWithCert :: Scriptic era => Proof era -> Core.TxBody era validatingBodyWithCert pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Collateral' [mkGenesisTxIn 13], @@ -576,7 +564,6 @@ validatingTxWithCert :: Core.Tx era validatingTxWithCert pf = newTx - override pf [ Body (validatingBodyWithCert pf), WitnessesI @@ -600,7 +587,7 @@ utxoStEx3 pf = smartUTxOState (utxoEx3 pf) (Coin 0) (Coin 5) def -- ===================================================================== outEx4 :: (Scriptic era) => Proof era -> Core.TxOut era -outEx4 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 995)] +outEx4 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 995)] redeemerExample4 :: Data era redeemerExample4 = Data (Plutus.I 0) @@ -616,7 +603,6 @@ scriptStakeCredFail pf = ScriptHashObj (alwaysFailsHash 1 pf) notValidatingBodyWithCert :: Scriptic era => Proof era -> Core.TxBody era notValidatingBodyWithCert pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 4], Collateral' [mkGenesisTxIn 14], @@ -635,7 +621,6 @@ notValidatingTxWithCert :: Core.Tx era notValidatingTxWithCert pf = newTx - override pf [ Body (notValidatingBodyWithCert pf), WitnessesI @@ -659,7 +644,7 @@ utxoStEx4 pf = smartUTxOState (utxoEx4 pf) (Coin 0) (Coin 5) def -- ============================================================================== outEx5 :: (Scriptic era) => Proof era -> Core.TxOut era -outEx5 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 1995)] +outEx5 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 1995)] redeemerExample5 :: Data era redeemerExample5 = Data (Plutus.I 42) @@ -672,7 +657,6 @@ validatingRedeemersEx5 = validatingBodyWithWithdrawal :: Scriptic era => Proof era -> Core.TxBody era validatingBodyWithWithdrawal pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 5], Collateral' [mkGenesisTxIn 15], @@ -696,7 +680,6 @@ validatingTxWithWithdrawal :: Core.Tx era validatingTxWithWithdrawal pf = newTx - override pf [ Body (validatingBodyWithWithdrawal pf), WitnessesI @@ -720,7 +703,7 @@ utxoStEx5 pf = smartUTxOState (utxoEx5 pf) (Coin 0) (Coin 5) def -- =========================================================================== outEx6 :: (Scriptic era) => Proof era -> Core.TxOut era -outEx6 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 1995)] +outEx6 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 1995)] redeemerExample6 :: Data era redeemerExample6 = Data (Plutus.I 0) @@ -733,7 +716,6 @@ notValidatingRedeemersEx6 = notValidatingBodyWithWithdrawal :: Scriptic era => Proof era -> Core.TxBody era notValidatingBodyWithWithdrawal pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 6], Collateral' [mkGenesisTxIn 16], @@ -757,7 +739,6 @@ notValidatingTxWithWithdrawal :: Core.Tx era notValidatingTxWithWithdrawal pf = newTx - override pf [ Body (notValidatingBodyWithWithdrawal pf), WitnessesI @@ -784,7 +765,7 @@ mintEx7 :: forall era. (Scriptic era, HasTokens era) => Proof era -> Core.Value mintEx7 pf = forge @era 1 (always 2 pf) outEx7 :: (HasTokens era, Scriptic era) => Proof era -> Core.TxOut era -outEx7 pf = newTxOut override pf [Address (someAddr pf), Amount (mintEx7 pf <+> inject (Coin 995))] +outEx7 pf = newTxOut pf [Address (someAddr pf), Amount (mintEx7 pf <+> inject (Coin 995))] redeemerExample7 :: Data era redeemerExample7 = Data (Plutus.I 42) @@ -797,7 +778,6 @@ validatingRedeemersEx7 = validatingBodyWithMint :: (HasTokens era, Scriptic era) => Proof era -> Core.TxBody era validatingBodyWithMint pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 7], Collateral' [mkGenesisTxIn 17], @@ -817,7 +797,6 @@ validatingTxWithMint :: Core.Tx era validatingTxWithMint pf = newTx - override pf [ Body (validatingBodyWithMint pf), WitnessesI @@ -845,7 +824,7 @@ mintEx8 :: forall era. (Scriptic era, HasTokens era) => Proof era -> Core.Value mintEx8 pf = forge @era 1 (never 1 pf) outEx8 :: (HasTokens era, Scriptic era) => Proof era -> Core.TxOut era -outEx8 pf = newTxOut override pf [Address (someAddr pf), Amount (mintEx8 pf <+> inject (Coin 995))] +outEx8 pf = newTxOut pf [Address (someAddr pf), Amount (mintEx8 pf <+> inject (Coin 995))] redeemerExample8 :: Data era redeemerExample8 = Data (Plutus.I 0) @@ -858,7 +837,6 @@ notValidatingRedeemersEx8 = notValidatingBodyWithMint :: (HasTokens era, Scriptic era) => Proof era -> Core.TxBody era notValidatingBodyWithMint pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 8], Collateral' [mkGenesisTxIn 18], @@ -878,7 +856,6 @@ notValidatingTxWithMint :: Core.Tx era notValidatingTxWithMint pf = newTx - override pf [ Body (notValidatingBodyWithMint pf), WitnessesI @@ -917,7 +894,6 @@ mintEx9 pf = forge @era 1 (always 2 pf) <+> forge @era 1 (timelockScript 1 pf) outEx9 :: (HasTokens era, PostShelley era) => Proof era -> Core.TxOut era outEx9 pf = newTxOut - override pf [ Address (someAddr pf), Amount (mintEx9 pf <+> inject (Coin 4996)) @@ -932,7 +908,6 @@ validatingBodyManyScripts :: Core.TxBody era validatingBodyManyScripts pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1, mkGenesisTxIn 100], Collateral' [mkGenesisTxIn 11], @@ -964,7 +939,6 @@ validatingTxManyScripts :: Core.Tx era validatingTxManyScripts pf = newTx - override pf [ Body (validatingBodyManyScripts pf), WitnessesI @@ -1007,7 +981,6 @@ utxoStEx9 pf = smartUTxOState (utxoEx9 pf) (Coin 0) (Coin 5) def outEx10 :: forall era. (Scriptic era) => Proof era -> Core.TxOut era outEx10 pf = newTxOut - override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 995), @@ -1017,7 +990,6 @@ outEx10 pf = okSupplimentaryDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era okSupplimentaryDatumTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Outputs' [outEx10 pf], @@ -1034,7 +1006,6 @@ okSupplimentaryDatumTx :: Core.Tx era okSupplimentaryDatumTx pf = newTx - override pf [ Body (okSupplimentaryDatumTxBody pf), WitnessesI @@ -1067,7 +1038,6 @@ multipleEqualCertsRedeemers = multipleEqualCertsBody :: Scriptic era => Proof era -> Core.TxBody era multipleEqualCertsBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Collateral' [mkGenesisTxIn 13], @@ -1089,7 +1059,6 @@ multipleEqualCertsTx :: Core.Tx era multipleEqualCertsTx pf = newTx - override pf [ Body (multipleEqualCertsBody pf), WitnessesI @@ -1117,12 +1086,11 @@ utxoStEx11 pf = smartUTxOState (utxoEx11 pf) (Coin 0) (Coin 5) def -- ==================================================================================== outEx12 :: Scriptic era => Proof era -> Core.TxOut era -outEx12 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 1216)] +outEx12 pf = newTxOut pf [Address (someAddr pf), Amount (inject $ Coin 1216)] nonScriptOutWithDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era nonScriptOutWithDatumTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 103], Outputs' [outEx12 pf], @@ -1138,7 +1106,6 @@ nonScriptOutWithDatumTx :: Core.Tx era nonScriptOutWithDatumTx pf = newTx - override pf [ Body (nonScriptOutWithDatumTxBody pf), WitnessesI @@ -1169,7 +1136,6 @@ utxoStEx12 pf = incorrectNetworkIDTxBody :: Era era => Proof era -> Core.TxBody era incorrectNetworkIDTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Outputs' [outEx3 pf], @@ -1180,7 +1146,6 @@ incorrectNetworkIDTxBody pf = incorrectNetworkIDTx :: (Era era, SignBody era) => Proof era -> Core.Tx era incorrectNetworkIDTx pf = newTx - override pf [ Body (incorrectNetworkIDTxBody pf), WitnessesI @@ -1194,7 +1159,6 @@ extraneousKeyHash = hashKey . snd . mkKeyPair $ RawSeed 0 0 0 0 99 missingRequiredWitnessTxBody :: Era era => Proof era -> Core.TxBody era missingRequiredWitnessTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Outputs' [outEx3 pf], @@ -1205,7 +1169,6 @@ missingRequiredWitnessTxBody pf = missingRequiredWitnessTx :: (Era era, SignBody era) => Proof era -> Core.Tx era missingRequiredWitnessTx pf = newTx - override pf [ Body (missingRequiredWitnessTxBody pf), WitnessesI @@ -1216,7 +1179,6 @@ missingRequiredWitnessTx pf = missingRedeemerTxBody :: Scriptic era => Proof era -> Core.TxBody era missingRedeemerTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -1231,7 +1193,6 @@ missingRedeemerTx :: Core.Tx era missingRedeemerTx pf = newTx - override pf [ Body (missingRedeemerTxBody pf), WitnessesI @@ -1247,7 +1208,6 @@ wrongWppHashTx :: Core.Tx era wrongWppHashTx pf = newTx - override pf [ Body (missingRedeemerTxBody pf), WitnessesI @@ -1268,7 +1228,6 @@ missing1phaseScriptWitnessTx :: Core.Tx era missing1phaseScriptWitnessTx pf = newTx - override pf [ Body (validatingBodyManyScripts pf), WitnessesI @@ -1298,7 +1257,6 @@ missing2phaseScriptWitnessTx :: Core.Tx era missing2phaseScriptWitnessTx pf = newTx - override pf [ Body (validatingBodyManyScripts pf), WitnessesI @@ -1327,7 +1285,6 @@ misPurposedRedeemer = wrongRedeemerLabelTxBody :: Scriptic era => Proof era -> Core.TxBody era wrongRedeemerLabelTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -1345,7 +1302,6 @@ wrongRedeemerLabelTx :: Core.Tx era wrongRedeemerLabelTx pf = newTx - override pf [ Body (wrongRedeemerLabelTxBody pf), WitnessesI @@ -1359,7 +1315,6 @@ wrongRedeemerLabelTx pf = missingDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era missingDatumTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -1377,7 +1332,6 @@ missingDatumTx :: Core.Tx era missingDatumTx pf = newTx - override pf [ Body (missingDatumTxBody pf), WitnessesI @@ -1397,7 +1351,6 @@ phase1FailureTx :: Core.Tx era phase1FailureTx pf = newTx - override pf [ Body (validatingBodyManyScripts pf), WitnessesI @@ -1426,7 +1379,6 @@ validatingRedeemersTooManyExUnits = tooManyExUnitsTxBody :: Scriptic era => Proof era -> Core.TxBody era tooManyExUnitsTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 1], Collateral' [mkGenesisTxIn 11], @@ -1444,7 +1396,6 @@ tooManyExUnitsTx :: Core.Tx era tooManyExUnitsTx pf = newTx - override pf [ Body (tooManyExUnitsTxBody pf), WitnessesI @@ -1462,7 +1413,6 @@ missingCollateralSig :: Core.Tx era missingCollateralSig pf = newTx - override pf [ Body (validatingBody pf), WitnessesI @@ -1475,7 +1425,6 @@ missingCollateralSig pf = plutusOutputWithNoDataTxBody :: Scriptic era => Proof era -> Core.TxBody era plutusOutputWithNoDataTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 101], Collateral' [mkGenesisTxIn 11], @@ -1493,7 +1442,6 @@ plutusOutputWithNoDataTx :: Core.Tx era plutusOutputWithNoDataTx pf = newTx - override pf [ Body (plutusOutputWithNoDataTxBody pf), WitnessesI @@ -1507,12 +1455,11 @@ totallyIrrelevantDatum :: Data era totallyIrrelevantDatum = Data (Plutus.I 1729) outputWithNoDatum :: forall era. Era era => Proof era -> Core.TxOut era -outputWithNoDatum pf = newTxOut override pf [Address $ someAddr pf, Amount (inject $ Coin 995)] +outputWithNoDatum pf = newTxOut pf [Address $ someAddr pf, Amount (inject $ Coin 995)] notOkSupplimentaryDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era notOkSupplimentaryDatumTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Outputs' [outputWithNoDatum pf], @@ -1531,7 +1478,6 @@ notOkSupplimentaryDatumTx :: Core.Tx era notOkSupplimentaryDatumTx pf = newTx - override pf [ Body (notOkSupplimentaryDatumTxBody pf), WitnessesI @@ -1546,10 +1492,9 @@ hashsize = fromIntegral $ sizeHash ([] @(CC.HASH c)) poolMDHTooBigTxBody :: forall era. Scriptic era => Proof era -> Core.TxBody era poolMDHTooBigTxBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], - Outputs' [newTxOut override pf [Address $ someAddr pf, Amount (inject $ Coin 995)]], + Outputs' [newTxOut pf [Address $ someAddr pf, Amount (inject $ Coin 995)]], Certs' [DCertPool (RegPool poolParams)], Txfee (Coin 5) ] @@ -1579,7 +1524,6 @@ poolMDHTooBigTx pf = -- Note that the UTXOW rule will no trigger the expected predicate failure, -- since it is checked in the POOL rule. BBODY will trigger it, however. newTx - override pf [ Body (poolMDHTooBigTxBody pf), WitnessesI @@ -1598,7 +1542,6 @@ multipleEqualCertsRedeemersInvalid = multipleEqualCertsBodyInvalid :: Scriptic era => Proof era -> Core.TxBody era multipleEqualCertsBodyInvalid pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 3], Collateral' [mkGenesisTxIn 13], @@ -1620,7 +1563,6 @@ multipleEqualCertsTxInvalid :: Core.Tx era multipleEqualCertsTxInvalid pf = newTx - override pf [ Body (multipleEqualCertsBodyInvalid pf), WitnessesI @@ -1633,7 +1575,6 @@ multipleEqualCertsTxInvalid pf = noCostModelBody :: Scriptic era => Proof era -> Core.TxBody era noCostModelBody pf = newTxBody - override pf [ Inputs' [mkGenesisTxIn 102], Collateral' [mkGenesisTxIn 11], @@ -1651,7 +1592,6 @@ noCostModelTx :: Core.Tx era noCostModelTx pf = newTx - override pf [ Body (noCostModelBody pf), WitnessesI @@ -2256,7 +2196,6 @@ testEvaluateTransactionFee = pparams = newPParams pf $ defaultPPs ++ [MinfeeA 1] validatingTxNoWits = newTx - override pf [ Body (validatingBody pf), WitnessesI diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs index 7a89ec9a202..c77d4a50ea6 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs @@ -45,7 +45,7 @@ where import Cardano.Ledger.Address (Addr (..)) import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash, Data (..), DataHash, hashData) import Cardano.Ledger.Alonzo.Language (Language (..)) -import Cardano.Ledger.Alonzo.Scripts (CostModel (..), ExUnits (..), Prices (..)) +import Cardano.Ledger.Alonzo.Scripts (CostModel (..), ExUnits (..), Prices) import qualified Cardano.Ledger.Alonzo.Tx as Alonzo (IsValid (..), ScriptIntegrityHash, ValidatedTx (..)) import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..)) import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxDats (..), TxWitness (..)) @@ -114,7 +114,7 @@ data TxBodyField era | Wdrls (Wdrl (Crypto era)) | Txfee Coin | Vldt ValidityInterval - | Slot SlotNo + | TTL SlotNo | Update (StrictMaybe (PP.Update era)) | ReqSignerHashes (Set (KeyHash 'Witness (Crypto era))) | Mint (Core.Value era) @@ -219,6 +219,8 @@ data PParamsField era MaxValSize (Natural) | -- | The scaling percentage of the collateral relative to the fee CollateralPercentage (Natural) + | -- | Maximum number of collateral inputs allowed in a transaction + MaxCollateralInputs Natural -- ========================================================================= -- Era parametric "empty" or initial values. @@ -364,8 +366,8 @@ abstractTxBody (Babbage _) (Babbage.TxBody inp col ref out colret totcol cert wd AdHash adh, Txnetworkid net ] -abstractTxBody (Shelley _) (Shelley.TxBody inp out cert wdrl fee slot up adh) = - [Inputs inp, Outputs out, Certs cert, Wdrls wdrl, Txfee fee, Slot slot, Update up, AdHash adh] +abstractTxBody (Shelley _) (Shelley.TxBody inp out cert wdrl fee ttlslot up adh) = + [Inputs inp, Outputs out, Certs cert, Wdrls wdrl, Txfee fee, TTL ttlslot, Update up, AdHash adh] abstractTxBody (Mary _) (MA.TxBody inp out cert wdrl fee vldt up adh mnt) = [Inputs inp, Outputs out, Certs cert, Wdrls wdrl, Txfee fee, Vldt vldt, Update up, AdHash adh, Mint mnt] abstractTxBody (Allegra _) (MA.TxBody inp out cert wdrl fee vldt up adh mnt) = @@ -614,3 +616,33 @@ pattern DHash' x <- DHash' x = DHash (toStrictMaybe x) -- ======================= + +{- + +import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams' (..)) +getPParamField :: Proof era -> Core.PParams era -> PParamsField era -> PParamsField era +getPParamField (Babbage _) pp field =case field of + (MinfeeA _) -> MinfeeA (Babbage._minfeeA pp) + (MinfeeB _) -> MinfeeB (Babbage._minfeeB pp) + (MaxBBSize _) -> MaxBBSize (Babbage._maxBBSize pp) + (MaxTxSize _) -> MaxTxSize (Babbage._maxTxSize pp) + (MaxBHSize _) -> MaxBHSize (Babbage._maxBHSize pp) + (KeyDeposit _) -> KeyDeposit (Babbage._keyDeposit pp) + (PoolDeposit _) -> PoolDeposit (Babbage._poolDeposit pp) + (EMax _) -> EMax (Babbage._eMax pp) + (NOpt _) -> NOpt (Babbage._nOpt pp) + (A0 _) -> A0(Babbage._a0 pp) + (Rho _) -> Rho(Babbage._rho pp) + (Tau _) -> Tau(Babbage._tau pp) + (ProtocolVersion _) -> ProtocolVersion (Babbage._protocolVersion pp) + (MinPoolCost _) -> MinPoolCost (Babbage._minPoolCost pp) + (Costmdls _) -> Costmdls(Babbage._costmdls pp) + (Prices _) -> Prices(Babbage._prices pp) + (MaxValSize _) -> MaxValSize(Babbage._maxValSize pp) + (MaxTxExUnits _) -> MaxTxExUnits(Babbage._maxTxExUnits pp) + (MaxBlockExUnits _) -> MaxBlockExUnits(Babbage._maxBlockExUnits pp) + (CollateralPercentage _) -> CollateralPercentage(Babbage._collateralPercentage pp) + (MaxCollateralInputs _) -> MaxCollateralInputs (Babbage._maxCollateralInputs pp) + other -> error ("Babbage does not have this field") + +-} diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs new file mode 100644 index 00000000000..c18fa0bb5f5 --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- PrettyA (PredicateFailure (Core.EraRule "UTXO" era)) +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Generic.PrettyCore where + +-- import Cardano.Ledger.Babbage(BabbageEra) + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +-- ------------------------------ +-- Predicatefailures + +-- import qualified Cardano.Ledger.Shelley.Rules.Utxo as Shelley(UtxoPredicateFailure(..)) + +import Cardano.Ledger.Alonzo.PlutusScriptApi (CollectError (..)) +import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (UtxoPredicateFailure (..)) +import Cardano.Ledger.Alonzo.Rules.Utxos (TagMismatchDescription (..), UtxosPredicateFailure (..)) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (..)) +-- ------------- +-- Specific types + +-- import Cardano.Ledger.Alonzo.TxWitness(TxWitness (..)) + +import Cardano.Ledger.Alonzo.Scripts (Script (..)) +import Cardano.Ledger.Alonzo.Tx (ScriptPurpose (..)) +import Cardano.Ledger.Alonzo.TxInfo (FailureDescription (..)) +import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Crypto as CC (Crypto) +import Cardano.Ledger.Era (Era (..)) +import Cardano.Ledger.Keys (hashKey) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Pretty +import Cardano.Ledger.Pretty.Alonzo +import Cardano.Ledger.Pretty.Mary +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.LedgerState (WitHashes (..)) +import Cardano.Ledger.Shelley.Rules.Ledger (LedgerPredicateFailure (..)) +import qualified Cardano.Ledger.Shelley.Rules.Ppup as Shelley (PpupPredicateFailure (..)) +import qualified Cardano.Ledger.Shelley.Rules.Utxo as Shelley (UtxoPredicateFailure (..)) +import Cardano.Ledger.Shelley.Rules.Utxow (UtxowPredicateFailure (..)) +import Cardano.Ledger.Shelley.TxBody (WitVKey (..)) +import qualified Cardano.Ledger.ShelleyMA.Rules.Utxo as Mary (UtxoPredicateFailure (..)) +import Control.State.Transition.Extended (PredicateFailure) +import Data.Typeable (Typeable) +import Test.Cardano.Ledger.Generic.Proof + +-- ===================================================== + +class Era era => PrettyCore era where + prettyTx :: Core.Tx era -> PDoc + prettyScript :: Core.Script era -> PDoc + prettyTxBody :: Core.TxBody era -> PDoc + prettyWitnesses :: Core.Witnesses era -> PDoc + prettyValue :: Core.Value era -> PDoc + prettyTxOut :: Core.TxOut era -> PDoc + +instance CC.Crypto c => PrettyCore (ShelleyEra c) where + prettyTx = Cardano.Ledger.Pretty.ppTx + prettyScript = ppMultiSig + prettyTxBody = Cardano.Ledger.Pretty.ppTxBody + prettyWitnesses = ppWitnessSetHKD + prettyValue = ppCoin + prettyTxOut = Cardano.Ledger.Pretty.ppTxOut + +instance CC.Crypto c => PrettyCore (AllegraEra c) where + prettyTx = Cardano.Ledger.Pretty.ppTx + prettyScript = ppTimelock + prettyTxBody = Cardano.Ledger.Pretty.Mary.ppTxBody + prettyWitnesses = ppWitnessSetHKD + prettyValue = ppCoin + prettyTxOut = Cardano.Ledger.Pretty.ppTxOut + +instance CC.Crypto c => PrettyCore (MaryEra c) where + prettyTx = Cardano.Ledger.Pretty.ppTx + prettyScript = ppTimelock + prettyTxBody = Cardano.Ledger.Pretty.Mary.ppTxBody + prettyWitnesses = ppWitnessSetHKD + prettyValue = ppValue + prettyTxOut = Cardano.Ledger.Pretty.ppTxOut + +instance CC.Crypto c => PrettyCore (AlonzoEra c) where + prettyTx = Cardano.Ledger.Pretty.Alonzo.ppTx + prettyScript = ppScript + prettyTxBody = Cardano.Ledger.Pretty.Alonzo.ppTxBody + prettyWitnesses = ppTxWitness + prettyValue = ppValue + prettyTxOut = Cardano.Ledger.Pretty.Alonzo.ppTxOut + +-- =================================================================== +-- PrettyA instances for UTXOW, UTXO, UTXOS, PPUP predicate failures +-- There are sometimes two versions: +-- one introduced in Shelley, one introduced in Alonzo +-- =================================================================== + +-- Predicate Failure for LEDGER + +ppLedgerPredicateFailure :: + ( PrettyA (PredicateFailure (Core.EraRule "UTXOW" era)), + Show (PredicateFailure (Core.EraRule "DELEGS" era)) + ) => + LedgerPredicateFailure era -> + PDoc +ppLedgerPredicateFailure (UtxowFailure x) = prettyA x +ppLedgerPredicateFailure (DelegsFailure x) = ppString (show x) + +instance + ( PrettyA (PredicateFailure (Core.EraRule "UTXOW" era)), + Show (PredicateFailure (Core.EraRule "DELEGS" era)) + ) => + PrettyA (LedgerPredicateFailure era) + where + prettyA = ppLedgerPredicateFailure + +instance + ( PrettyA (PredicateFailure (Core.EraRule "UTXOW" era)), + Show (PredicateFailure (Core.EraRule "DELEGS" era)) + ) => + PrettyA [LedgerPredicateFailure era] + where + prettyA = ppList prettyA + +-- ========================================= +-- Predicate Failure for Alonzo UTXOW + +ppAlonzoPredFail :: + ( PrettyA (PredicateFailure (Core.EraRule "UTXO" era)), + PrettyCore era + ) => + AlonzoPredFail era -> + PDoc +ppAlonzoPredFail (WrappedShelleyEraFailure x) = prettyA x +ppAlonzoPredFail (MissingRedeemers xs) = + ppSexp "MissingRedeemers" [ppList (ppPair ppScriptPurpose ppScriptHash) xs] +ppAlonzoPredFail (MissingRequiredDatums s1 s2) = + ppRecord + "MissingRequiredDatums" + [ ("missing data hashes", ppSet ppSafeHash s1), + ("received data hashes", ppSet ppSafeHash s2) + ] +ppAlonzoPredFail (NonOutputSupplimentaryDatums s1 s2) = + ppRecord + "NonOutputSupplimentaryDatums" + [ ("unallowed data hashes", ppSet ppSafeHash s1), + ("acceptable data hashes", ppSet ppSafeHash s2) + ] +ppAlonzoPredFail (PPViewHashesDontMatch h1 h2) = + ppRecord + "NonOutputSupplimentaryDatums" + [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash h1), + ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash h2) + ] +ppAlonzoPredFail (MissingRequiredSigners x) = + ppSexp "MissingRequiredSigners" [ppSet ppKeyHash x] +ppAlonzoPredFail (UnspendableUTxONoDatumHash x) = + ppSexp "UnspendableUTxONoDatumHash" [ppSet ppTxIn x] +ppAlonzoPredFail (ExtraRedeemers x) = + ppSexp "ExtraRedeemers" [ppList prettyA x] + +instance + ( PrettyA (PredicateFailure (Core.EraRule "UTXO" era)), + PrettyCore era + ) => + PrettyA (AlonzoPredFail era) + where + prettyA = ppAlonzoPredFail + +-- ==================================================== +-- Predicate Failure for Shelley UTXOW + +ppUtxowPredicateFailure :: + ( PrettyA (PredicateFailure (Core.EraRule "UTXO" era)), + PrettyCore era + ) => + UtxowPredicateFailure era -> + PDoc +ppUtxowPredicateFailure (InvalidWitnessesUTXOW vkeyws) = + ppSexp "InvalidWitnessesUTXOW" [ppList ppVKey vkeyws] +ppUtxowPredicateFailure (MissingVKeyWitnessesUTXOW whs) = + ppSexp "MissingVKeyWitnessesUTXOW" [ppWitHashes whs] +ppUtxowPredicateFailure (MissingScriptWitnessesUTXOW m) = + ppSexp "MissingScriptWitnessesUTXOW" [ppSet ppScriptHash m] +ppUtxowPredicateFailure (ScriptWitnessNotValidatingUTXOW m) = + ppSexp "ScriptWitnessNotValidatingUTXOW" [ppSet ppScriptHash m] +ppUtxowPredicateFailure (UtxoFailure m) = ppSexp "UtxoFailure" [prettyA m] +ppUtxowPredicateFailure (MIRInsufficientGenesisSigsUTXOW m) = + ppSexp "MIRInsufficientGenesisSigsUTXOW" [ppSet ppKeyHash m] +ppUtxowPredicateFailure (MissingTxBodyMetadataHash m) = + ppSexp " MissingTxMetadata" [ppAuxiliaryDataHash m] +ppUtxowPredicateFailure (MissingTxMetadata m) = + ppSexp " MissingTxMetadata" [ppAuxiliaryDataHash m] +ppUtxowPredicateFailure (ConflictingMetadataHash h1 h2) = + ppRecord "ConflictingMetadataHash" [("Hash in the body", ppAuxiliaryDataHash h1), ("Hash of full metadata", ppAuxiliaryDataHash h2)] +ppUtxowPredicateFailure (InvalidMetadata) = + ppSexp "InvalidMetadata" [] +ppUtxowPredicateFailure (ExtraneousScriptWitnessesUTXOW m) = + ppSexp "ExtraneousScriptWitnessesUTXOW" [ppSet ppScriptHash m] + +instance + ( PrettyA (PredicateFailure (Core.EraRule "UTXO" era)), + PrettyCore era + ) => + PrettyA (UtxowPredicateFailure era) + where + prettyA = ppUtxowPredicateFailure + +-- ======================================================== +-- Predicate Failure for Alonzo UTXO + +ppUtxoPredicateFailure :: + forall era. + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "UTXOS" era)), + PrettyA (Core.TxOut era) -- From ppUTxO FIXME + ) => + Alonzo.UtxoPredicateFailure era -> + PDoc +ppUtxoPredicateFailure (Alonzo.BadInputsUTxO x) = + ppSexp "BadInputsUTxO" [ppSet ppTxIn x] +ppUtxoPredicateFailure (Alonzo.OutsideValidityIntervalUTxO vi slot) = + ppRecord "OutsideValidityIntervalUTxO" [("validity interval", ppValidityInterval vi), ("slot", ppSlotNo slot)] +ppUtxoPredicateFailure (Alonzo.MaxTxSizeUTxO actual maxs) = + ppRecord + "MaxTxSizeUTxO" + [ ("Actual", ppInteger actual), + ("max transaction size", ppInteger maxs) + ] +ppUtxoPredicateFailure (Alonzo.InputSetEmptyUTxO) = + ppSexp "InputSetEmptyUTxO" [] +ppUtxoPredicateFailure (Alonzo.FeeTooSmallUTxO computed supplied) = + ppRecord + "FeeTooSmallUTxO" + [ ("min fee for thistransaction", ppCoin computed), + ("fee supplied by transaction", ppCoin supplied) + ] +ppUtxoPredicateFailure (Alonzo.ValueNotConservedUTxO consumed produced) = + ppRecord + "ValueNotConservedUTxO" + [ ("coin consumed", prettyValue @era consumed), + ("coin produced", prettyValue @era produced) + ] +ppUtxoPredicateFailure (Alonzo.WrongNetwork n add) = + ppRecord + "WrongNetwork" + [ ("expected network id", ppNetwork n), + ("set addresses with wrong network id", ppSet ppAddr add) + ] +ppUtxoPredicateFailure (Alonzo.WrongNetworkWithdrawal n accnt) = + ppRecord + "WrongNetworkWithdrawal" + [ ("expected network id", ppNetwork n), + ("set reward address with wrong network id", ppSet ppRewardAcnt accnt) + ] +ppUtxoPredicateFailure (Alonzo.OutputTooSmallUTxO xs) = + ppSexp "OutputTooSmallUTxO" [ppList prettyTxOut xs] +ppUtxoPredicateFailure (Alonzo.UtxosFailure subpred) = + ppSexp "UtxosFailure" [prettyA subpred] +ppUtxoPredicateFailure (Alonzo.OutputBootAddrAttrsTooBig x) = + ppSexp "OutputBootAddrAttrsTooBig" [ppList prettyTxOut x] +ppUtxoPredicateFailure (Alonzo.TriesToForgeADA) = + ppSexp "TriesToForgeADA" [] +ppUtxoPredicateFailure (Alonzo.OutputTooBigUTxO xs) = + ppSexp + "OutputTooBigUTxO" + [ ppList + ( \(a, b, c) -> + ppRecord + "" + [("actual size", ppInt a), ("PParam max value", ppInt b), ("TxOut", prettyTxOut c)] + ) + xs + ] +ppUtxoPredicateFailure (Alonzo.InsufficientCollateral x y) = + ppRecord + "InsufficientCollateral" + [ ("balance computed", ppCoin x), + ("the required collateral for the given fee", ppCoin y) + ] +ppUtxoPredicateFailure (Alonzo.ScriptsNotPaidUTxO x) = + ppSexp "ScriptsNotPaidUTxO" [ppUTxO x] +ppUtxoPredicateFailure (Alonzo.ExUnitsTooBigUTxO x y) = + ppRecord + "ExUnitsTooBigUTxO" + [ ("Max EXUnits from the protocol parameters", ppExUnits x), + ("EXUnits supplied", ppExUnits y) + ] +ppUtxoPredicateFailure (Alonzo.CollateralContainsNonADA x) = + ppSexp "CollateralContainsNonADA" [prettyValue @era x] +ppUtxoPredicateFailure (Alonzo.WrongNetworkInTxBody x y) = + ppRecord + "WrongNetworkInTxBody" + [ ("Actual Network ID", ppNetwork x), + ("Network ID in transaction body", ppNetwork y) + ] +ppUtxoPredicateFailure (Alonzo.OutsideForecast x) = + ppRecord "OutsideForecast" [("slot number outside consensus forecast range", ppSlotNo x)] +ppUtxoPredicateFailure (Alonzo.TooManyCollateralInputs x y) = + ppRecord + "TooManyCollateralInputs" + [ ("Max allowed collateral inputs", ppNatural x), + ("Number of collateral inputs", ppNatural y) + ] +ppUtxoPredicateFailure (Alonzo.NoCollateralInputs) = + ppSexp "NoCollateralInputs" [] + +instance + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "UTXOS" era)), + PrettyA (Core.TxOut era) -- From ppUTxO FIXME + ) => + PrettyA (Alonzo.UtxoPredicateFailure era) + where + prettyA = ppUtxoPredicateFailure + +-- ========================================= +-- Predicate Failure for Alonzo UTXOS + +ppUtxosPredicateFailure :: + PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) => + UtxosPredicateFailure era -> + PDoc +ppUtxosPredicateFailure (ValidationTagMismatch isvalid tag) = + ppRecord + "ValidationTagMismatch" + [ ("isValid tag", ppIsValid isvalid), + ("mismatch description", ppTagMismatchDescription tag) + ] +ppUtxosPredicateFailure (CollectErrors es) = + ppRecord "CollectErrors" [("When collecting inputs for twophase scripts, these went wrong.", ppList ppCollectError es)] +ppUtxosPredicateFailure (UpdateFailure p) = prettyA p + +instance PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) => PrettyA (UtxosPredicateFailure era) where + prettyA = ppUtxosPredicateFailure + +ppCollectError :: CollectError crypto -> PDoc +ppCollectError (NoRedeemer sp) = ppSexp "NoRedeemer" [ppScriptPurpose sp] +ppCollectError (NoWitness sh) = ppSexp "NoWitness" [ppScriptHash sh] +ppCollectError (NoCostModel l) = ppSexp "NoCostModel" [ppLanguage l] +ppCollectError (BadTranslation x) = ppSexp "BadTranslation" [ppString (show x)] + +instance PrettyA (CollectError crypto) where + prettyA = ppCollectError + +ppTagMismatchDescription :: TagMismatchDescription -> PDoc +ppTagMismatchDescription (PassedUnexpectedly) = ppSexp "PassedUnexpectedly" [] +ppTagMismatchDescription (FailedUnexpectedly xs) = + ppSexp "FailedUnexpectedly" [ppList ppFailureDescription xs] + +instance PrettyA TagMismatchDescription where + prettyA = ppTagMismatchDescription + +ppFailureDescription :: FailureDescription -> PDoc +ppFailureDescription (OnePhaseFailure txt) = + ppSexp "OnePhaseFailure" [text txt] +ppFailureDescription (PlutusFailure txt bytes) = + ppRecord "PlutusFailure" [("reason", text txt), ("script", ppLong bytes)] + +instance PrettyA FailureDescription where + prettyA = ppFailureDescription + +-- ======================================= +-- Predicate Failure for Shelley UTxO + +ppUtxoPFShelley :: + forall era. + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + Shelley.UtxoPredicateFailure era -> + PDoc +ppUtxoPFShelley (Shelley.BadInputsUTxO x) = + ppSexp "BadInputsUTxO" [ppSet ppTxIn x] +ppUtxoPFShelley (Shelley.ExpiredUTxO ttl slot) = + ppRecord "ExpiredUTxO" [("transaction time to live", ppSlotNo ttl), ("current slot", ppSlotNo slot)] +ppUtxoPFShelley (Shelley.MaxTxSizeUTxO actual maxs) = + ppRecord + "MaxTxSizeUTxO" + [ ("Actual", ppInteger actual), + ("max transaction size", ppInteger maxs) + ] +ppUtxoPFShelley (Shelley.InputSetEmptyUTxO) = + ppSexp "InputSetEmptyUTxO" [] +ppUtxoPFShelley (Shelley.FeeTooSmallUTxO computed supplied) = + ppRecord + "FeeTooSmallUTxO" + [ ("min fee for this transaction", ppCoin computed), + ("fee supplied by this transaction", ppCoin supplied) + ] +ppUtxoPFShelley (Shelley.ValueNotConservedUTxO consumed produced) = + ppRecord + "ValueNotConservedUTxO" + [ ("coin consumed", prettyValue @era consumed), + ("coin produced", prettyValue @era produced) + ] +ppUtxoPFShelley (Shelley.WrongNetwork n add) = + ppRecord + "WrongNetwork" + [ ("expected network id", ppNetwork n), + ("set of addresses with wrong network id", ppSet ppAddr add) + ] +ppUtxoPFShelley (Shelley.WrongNetworkWithdrawal n accnt) = + ppRecord + "WrongNetworkWithdrawal" + [ ("expected network id", ppNetwork n), + ("set of reward address with wrong network id", ppSet ppRewardAcnt accnt) + ] +ppUtxoPFShelley (Shelley.OutputTooSmallUTxO xs) = + ppRecord + "OutputTooSmallUTxO" + [("list of supplied transaction outputs that are too small", ppList prettyTxOut xs)] +ppUtxoPFShelley (Shelley.UpdateFailure x) = + ppSexp "UpdateFailure" [prettyA x] +ppUtxoPFShelley (Shelley.OutputBootAddrAttrsTooBig xs) = + ppRecord "OutputBootAddrAttrsTooBig" [("list of supplied bad transaction outputs", ppList prettyTxOut xs)] + +instance + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + PrettyA (Shelley.UtxoPredicateFailure era) + where + prettyA = ppUtxoPFShelley + +-- ======================================= +-- Predicate Failure for Shelley PPUP + +ppPpupPredicateFailure :: Shelley.PpupPredicateFailure era -> PDoc +ppPpupPredicateFailure (Shelley.NonGenesisUpdatePPUP x y) = + ppRecord + "NonGenesisUpdatePPUP" + [ ("KeyHashes which are voting", ppSet ppKeyHash x), + ("KeyHashes which should be voting", ppSet ppKeyHash y) + ] +ppPpupPredicateFailure (Shelley.PPUpdateWrongEpoch x y z) = + ppRecord + "PPUpdateWrongEpoch" + [ ("current epoch", ppEpochNo x), + ("intended epoch of update", ppEpochNo y), + ("voting period within the epoch", ppString (show z)) + ] +ppPpupPredicateFailure (Shelley.PVCannotFollowPPUP x) = + ppRecord "PVCannotFollowPPUP" [("the first bad protocol version", ppProtVer x)] + +instance PrettyA (Shelley.PpupPredicateFailure era) where + prettyA = ppPpupPredicateFailure + +-- ===================================================== +-- Predicate failure for Mary UTXO + +ppUtxoPFMary :: + forall era. + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + Mary.UtxoPredicateFailure era -> + PDoc +ppUtxoPFMary (Mary.BadInputsUTxO txins) = + ppSexp "BadInputsUTxO" [ppSet ppTxIn txins] +ppUtxoPFMary (Mary.OutsideValidityIntervalUTxO vi slot) = + ppRecord + "OutsideValidityIntervalUTxO" + [ ("provided interval", ppValidityInterval vi), + ("current slot", ppSlotNo slot) + ] +ppUtxoPFMary (Mary.MaxTxSizeUTxO actual maxs) = + ppRecord + "MaxTxSizeUTxO" + [ ("Actual", ppInteger actual), + ("max transaction size", ppInteger maxs) + ] +ppUtxoPFMary (Mary.InputSetEmptyUTxO) = ppSexp "InputSetEmptyUTxO" [] +ppUtxoPFMary (Mary.FeeTooSmallUTxO computed supplied) = + ppRecord + "FeeTooSmallUTxO" + [ ("min fee for this transaction", ppCoin computed), + ("fee supplied by this transaction", ppCoin supplied) + ] +ppUtxoPFMary (Mary.ValueNotConservedUTxO consumed produced) = + ppRecord + "ValueNotConservedUTxO" + [ ("coin consumed", prettyValue @era consumed), + ("coin produced", prettyValue @era produced) + ] +ppUtxoPFMary (Mary.WrongNetwork n add) = + ppRecord + "WrongNetwork" + [ ("expected network id", ppNetwork n), + ("set of addresses with wrong network id", ppSet ppAddr add) + ] +ppUtxoPFMary (Mary.WrongNetworkWithdrawal n accnt) = + ppRecord + "WrongNetworkWithdrawal" + [ ("expected network id", ppNetwork n), + ("set reward address with wrong network id", ppSet ppRewardAcnt accnt) + ] +ppUtxoPFMary (Mary.OutputTooSmallUTxO xs) = + ppRecord + "OutputTooSmallUTxO" + [("list of supplied transaction outputs that are too small", ppList prettyTxOut xs)] +ppUtxoPFMary (Mary.UpdateFailure x) = + ppSexp "UpdateFailure" [prettyA x] +ppUtxoPFMary (Mary.OutputBootAddrAttrsTooBig xs) = + ppRecord "OutputBootAddrAttrsTooBig" [("list of supplied bad transaction outputs", ppList prettyTxOut xs)] +ppUtxoPFMary (Mary.TriesToForgeADA) = ppSexp "TriesToForgeADA" [] +ppUtxoPFMary (Mary.OutputTooBigUTxO outs) = + ppRecord "OutputTooBigUTxO" [("list of TxOuts which are too big", ppList prettyTxOut outs)] + +instance + ( PrettyCore era, + PrettyA (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + PrettyA (Mary.UtxoPredicateFailure era) + where + prettyA = ppUtxoPFMary + +-- ===================================================== +-- Probably should be moved elsewhere + +-- LedgerState.hs +ppWitHashes :: WitHashes crypto -> PDoc +ppWitHashes (WitHashes hs) = ppSexp "WitHashes" [ppSet ppKeyHash hs] + +instance PrettyA (WitHashes crypto) where + prettyA = ppWitHashes + +-- Defined in ‘Cardano.Ledger.Alonzo.Tx’ +ppScriptPurpose :: ScriptPurpose crypto -> PDoc +ppScriptPurpose (Minting policy) = ppSexp "Minting" [prettyA policy] -- FIXME fill in the blanks +ppScriptPurpose (Spending txin) = ppSexp "Spending" [ppTxIn txin] +ppScriptPurpose (Rewarding acct) = ppSexp "Rewarding" [ppRewardAcnt acct] +ppScriptPurpose (Certifying dcert) = ppSexp "Certifying" [ppDCert dcert] + +instance PrettyA (ScriptPurpose crypto) where + prettyA = ppScriptPurpose + +-- ===================================================== + +dots :: PDoc -> PDoc +dots _ = ppString "..." + +dotsF :: (a -> PDoc) -> (a -> PDoc) +dotsF _f _x = ppString "..." + +ppMyWay :: (Typeable keyrole, CC.Crypto c) => WitVKey keyrole c -> PDoc +ppMyWay (wvk@(WitVKey vkey _)) = ppSexp "MyWay" [ppKeyHash (hashKey vkey), ppWitVKey wvk] + +ppCoreWitnesses :: Proof era -> Core.Witnesses era -> PDoc +ppCoreWitnesses (Alonzo _) x = ppTxWitness x +ppCoreWitnesses (Babbage _) x = ppTxWitness x +ppCoreWitnesses (Mary _) x = ppWitnessSetHKD x +ppCoreWitnesses (Allegra _) x = ppWitnessSetHKD x +ppCoreWitnesses (Shelley _) x = ppWitnessSetHKD x + +ppCoreScript :: Proof era -> Core.Script era -> PDoc +ppCoreScript (Babbage _) (PlutusScript _ x) = ppString (show x) +ppCoreScript (Babbage _) (TimelockScript x) = ppTimelock x +ppCoreScript (Alonzo _) (PlutusScript _ x) = ppString (show x) +ppCoreScript (Alonzo _) (TimelockScript x) = ppTimelock x +ppCoreScript (Mary _) x = ppTimelock x +ppCoreScript (Allegra _) x = ppTimelock x +ppCoreScript (Shelley _) x = ppMultiSig x + +-- ======================================================= diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs new file mode 100644 index 00000000000..77828994b45 --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs @@ -0,0 +1,1406 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- Pretty instances of Predicate failures +{-# LANGUAGE UndecidableInstances #-} + +module Test.Cardano.Ledger.Generic.Properties where + +-- ================================= + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Data (Data, DataHash, binaryDataToData, hashData) +import Cardano.Ledger.Alonzo.Language (Language (..), nonNativeLanguages) +import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..)) +import Cardano.Ledger.Alonzo.PlutusScriptApi (scriptsNeeded) +import Cardano.Ledger.Alonzo.Scripts +import Cardano.Ledger.Alonzo.Tx + ( IsValid (..), + ScriptIntegrityHash, + ScriptPurpose (..), + ValidatedTx (..), + hashScriptIntegrity, + minfee, + ) +import Cardano.Ledger.Alonzo.TxBody (TxOut (..)) +import Cardano.Ledger.Alonzo.TxWitness + ( RdmrPtr (..), + Redeemers (..), + TxDats (..), + ) +import Cardano.Ledger.Babbage (BabbageEra) +import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams, PParams' (..)) +import qualified Cardano.Ledger.Babbage.TxBody as Babbage (Datum (..), TxOut (..)) +import Cardano.Ledger.BaseTypes + ( Network (..), + mkTxIxPartial, + ) +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 (..)) +import Cardano.Ledger.Hashes (EraIndependentTxBody, ScriptHash (..)) +import Cardano.Ledger.Keys + ( GenDelegs (..), + KeyHash (..), + KeyPair (..), + KeyRole (..), + coerceKeyRole, + hashKey, + ) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Pretty +import Cardano.Ledger.Pretty.Alonzo (ppData, ppIsValid, ppTag) +import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.API + ( Addr (..), + Credential (..), + LedgerEnv (LedgerEnv), + RewardAcnt (..), + StakeReference (..), + UTxO (..), + Wdrl (..), + ) +import Cardano.Ledger.Shelley.EpochBoundary (obligation) +import Cardano.Ledger.Shelley.LedgerState + ( AccountState (..), + DPState (..), + DState (..), + PState (..), + RewardAccounts, + UTxOState (..), + rewards, + ) +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley (minfee) +import qualified Cardano.Ledger.Shelley.PParams as Shelley (PParams, PParams' (..)) +import Cardano.Ledger.Shelley.Rules.Utxo (UtxoEnv (..)) +import qualified Cardano.Ledger.Shelley.Scripts as Shelley (MultiSig (..)) +import Cardano.Ledger.Shelley.Tx (hashScript) +import Cardano.Ledger.Shelley.TxBody (DCert (..), DelegCert (..), Delegation (..), PoolParams (..)) +import qualified Cardano.Ledger.Shelley.TxBody as Shelley (TxOut (..)) +import Cardano.Ledger.Shelley.UTxO (balance, makeWitnessVKey) +import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), ValidityInterval (..)) +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) +import Cardano.Ledger.UnifiedMap (ViewMap) +import Cardano.Ledger.Val +import Cardano.Slotting.Slot (SlotNo (..)) +import Control.Monad (forM, join, replicateM) +import Control.Monad.State.Strict (MonadState (..), modify) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.RWS.Strict (RWST (..), ask) +import Control.State.Transition.Extended hiding (Assertion) +import Data.Bifunctor (first) +import Data.Coerce +import qualified Data.Compact.SplitMap as SplitMap +import Data.Default.Class (Default (def)) +import qualified Data.Foldable as F +import Data.Functor +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromJust, mapMaybe) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Monoid (All (..)) +import Data.Ratio ((%)) +import qualified Data.Sequence.Strict as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.UMap (View (Rewards)) +import qualified Data.UMap as UM +import GHC.Stack +import Numeric.Natural +import Plutus.V1.Ledger.Api (defaultCostModelParams) +import Test.Cardano.Ledger.Alonzo.Scripts (alwaysFails, alwaysSucceeds) +import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () +import Test.Cardano.Ledger.Generic.Fields hiding (Mint) +import qualified Test.Cardano.Ledger.Generic.Fields as Generic (TxBodyField (Mint)) +import Test.Cardano.Ledger.Generic.PrettyCore +import Test.Cardano.Ledger.Generic.Proof hiding (lift) +import Test.Cardano.Ledger.Generic.Updaters hiding (first) +import Test.Cardano.Ledger.Shelley.Generator.Core (genNatural) +import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () +import Test.Cardano.Ledger.Shelley.Utils (runShelleyBase) +import Test.QuickCheck +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +{- + +import Debug.Trace +import Cardano.Ledger.Shelley.Rules.Ledger(LedgerPredicateFailure(..)) +import Cardano.Ledger.Shelley.Rules.Utxow(UtxowPredicateFailure(..)) +import qualified Cardano.Ledger.Shelley.Rules.Utxo as Shelley(UtxoPredicateFailure(..)) + +import Cardano.Ledger.Alonzo.Rules.Utxow(AlonzoPredFail(..)) +import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo(UtxoPredicateFailure(..)) +-} + +-- =================================================== +-- Assembing lists of Fields in to (Core.XX era) + +-- | This uses merging semantics, it expects duplicate fields, and merges them together +assembleWits :: Era era => Proof era -> [WitnessesField era] -> Core.Witnesses era +assembleWits era = List.foldl' (updateWitnesses merge era) (initialWitnesses era) + +coreTxOut :: Era era => Proof era -> [TxOutField era] -> Core.TxOut era +coreTxOut era dts = List.foldl' (updateTxOut era) (initialTxOut era) dts + +coreTxBody :: Era era => Proof era -> [TxBodyField era] -> Core.TxBody era +coreTxBody era dts = List.foldl' (updateTxBody era) (initialTxBody era) dts + +overrideTxBody :: Proof era -> Core.TxBody era -> [TxBodyField era] -> Core.TxBody era +overrideTxBody era old dts = List.foldl' (updateTxBody era) old dts + +coreTx :: Proof era -> [TxField era] -> Core.Tx era +coreTx era dts = List.foldl' (updateTx era) (initialTx era) dts + +-- ==================================================================== +-- Era agnostic actions on (Core.PParams era) (Core.TxOut era) and +-- other Core.XX types Mostly by pattern matching against Proof objects + +maxCollateralInputs' :: Proof era -> Core.PParams era -> Natural +maxCollateralInputs' (Alonzo _) x = _maxCollateralInputs x +maxCollateralInputs' (Babbage _) x = Babbage._maxCollateralInputs x +maxCollateralInputs' _proof _x = 0 + +maxTxExUnits' :: Proof era -> Core.PParams era -> ExUnits +maxTxExUnits' (Alonzo _) x = _maxTxExUnits x +maxTxExUnits' (Babbage _) x = Babbage._maxTxExUnits x +maxTxExUnits' _proof _x = mempty + +collateralPercentage' :: Proof era -> Core.PParams era -> Natural +collateralPercentage' (Alonzo _) x = _collateralPercentage x +collateralPercentage' (Babbage _) x = Babbage._collateralPercentage x +collateralPercentage' _proof _x = 0 + +obligation' :: + forall era c. + (c ~ Crypto era) => + Proof era -> + Core.PParams era -> + ViewMap c (Credential 'Staking c) Coin -> + Map (KeyHash 'StakePool c) (PoolParams c) -> + Coin +obligation' (Babbage _) = obligation @c @(Babbage.PParams era) @(ViewMap c) +obligation' (Alonzo _) = obligation @c @(PParams era) @(ViewMap c) +obligation' (Mary _) = obligation @c @(Shelley.PParams era) @(ViewMap c) +obligation' (Allegra _) = obligation @c @(Shelley.PParams era) @(ViewMap c) +obligation' (Shelley _) = obligation @c @(Shelley.PParams era) @(ViewMap c) + +minfee' :: forall era. Proof era -> Core.PParams era -> Core.Tx era -> Coin +minfee' (Alonzo _) = minfee @era @(ValidatedTx) +minfee' (Babbage _) = minfee @era @(ValidatedTx) +minfee' (Mary _) = Shelley.minfee +minfee' (Allegra _) = Shelley.minfee +minfee' (Shelley _) = Shelley.minfee + +hashScriptIntegrity' :: + Proof era -> + Core.PParams era -> + Set Language -> + Redeemers era -> + TxDats era -> -- (Map.Map (DataHash c) (Data era)) + StrictMaybe (ScriptIntegrityHash (Crypto era)) +hashScriptIntegrity' (Babbage _) = hashScriptIntegrity +hashScriptIntegrity' (Alonzo _) = hashScriptIntegrity +hashScriptIntegrity' _proof = (\_pp _l _r _d -> SNothing) + +-- | Break a TxOut into its mandatory and optional parts +txoutFields :: Proof era -> Core.TxOut era -> (Addr (Crypto era), Core.Value era, [TxOutField era]) +txoutFields (Alonzo _) (TxOut addr val dh) = (addr, val, [DHash dh]) +txoutFields (Babbage _) (Babbage.TxOut addr val d h) = (addr, val, [Datum d, RefScript h]) +txoutFields (Mary _) (Shelley.TxOut addr val) = (addr, val, []) +txoutFields (Allegra _) (Shelley.TxOut addr val) = (addr, val, []) +txoutFields (Shelley _) (Shelley.TxOut addr val) = (addr, val, []) + +injectFee :: Proof era -> Coin -> Core.TxOut era -> Core.TxOut era +injectFee (Babbage _) fee (Babbage.TxOut addr val d ref) = Babbage.TxOut addr (val <+> inject fee) d ref +injectFee (Alonzo _) fee (TxOut addr val mdh) = TxOut addr (val <+> inject fee) mdh +injectFee (Mary _) fee (Shelley.TxOut addr val) = Shelley.TxOut addr (val <+> inject fee) +injectFee (Allegra _) fee (Shelley.TxOut addr val) = Shelley.TxOut addr (val <+> inject fee) +injectFee (Shelley _) fee (Shelley.TxOut addr val) = Shelley.TxOut addr (val <+> inject fee) + +getTxOutVal :: Proof era -> Core.TxOut era -> Core.Value era +getTxOutVal (Babbage _) (Babbage.TxOut _ v _ _) = v +getTxOutVal (Alonzo _) (TxOut _ v _) = v +getTxOutVal (Mary _) (Shelley.TxOut _ v) = v +getTxOutVal (Allegra _) (Shelley.TxOut _ v) = v +getTxOutVal (Shelley _) (Shelley.TxOut _ v) = v + +emptyPPUPstate :: forall era. Proof era -> State (Core.EraRule "PPUP" era) +emptyPPUPstate (Babbage _) = def +emptyPPUPstate (Alonzo _) = def +emptyPPUPstate (Mary _) = def +emptyPPUPstate (Allegra _) = def +emptyPPUPstate (Shelley _) = def + +isValid' :: Proof era -> Core.Tx era -> IsValid +isValid' (Alonzo _) x = isValid x +isValid' (Babbage _) x = isValid x +isValid' _ _ = IsValid True + +txoutAddrHash :: Proof era -> Core.TxOut era -> (Addr (Crypto era), Maybe (DataHash (Crypto era))) +txoutAddrHash (Alonzo _) (TxOut addr _ (SJust dh)) = (addr, Just dh) +txoutAddrHash (Alonzo _) (TxOut addr _ SNothing) = (addr, Nothing) +txoutAddrHash (Babbage _) (Babbage.TxOut addr _ Babbage.NoDatum _) = (addr, Nothing) +txoutAddrHash (Babbage _) (Babbage.TxOut addr _ (Babbage.DatumHash dh) _) = (addr, Just dh) +txoutAddrHash (Babbage _) (Babbage.TxOut addr _ _ _) = (addr, Nothing) +txoutAddrHash (Mary _) (Shelley.TxOut addr _) = (addr, Nothing) +txoutAddrHash (Allegra _) (Shelley.TxOut addr _) = (addr, Nothing) +txoutAddrHash (Shelley _) (Shelley.TxOut addr _) = (addr, Nothing) + +-- ================================================== +-- Era agnostic generators. + +genMapElem :: Map k a -> Gen (Maybe (k, a)) +genMapElem m + | n == 0 = pure Nothing + | otherwise = do + i <- choose (0, n - 1) + pure $ Just $ Map.elemAt i m + where + n = Map.size m + +-- | Generate a non-zero value +genPositiveVal :: Val v => Gen v +genPositiveVal = inject . Coin . getPositive <$> arbitrary + +elementsT :: (Monad (t Gen), MonadTrans t) => [t Gen b] -> t Gen b +elementsT = join . lift . elements + +frequencyT :: (Monad (t Gen), MonadTrans t) => [(Int, t Gen b)] -> t Gen b +frequencyT = join . lift . frequency . map (pure <$>) + +lookupByKeyM :: + (MonadState s m, Ord k, Show k) => String -> k -> (s -> Map.Map k v) -> m v +lookupByKeyM name k getMap = do + m <- getMap <$> get + case Map.lookup k m of + Nothing -> + error $ + "Can't find " ++ name ++ " in the test enviroment: " ++ show k + Just val -> pure val + +data GenEnv era = GenEnv + { geValidityInterval :: ValidityInterval, + gePParams :: Core.PParams era + } + +data GenState era = GenState + { gsKeys :: Map (KeyHash 'Witness (Crypto era)) (KeyPair 'Witness (Crypto era)), + gsScripts :: Map (ScriptHash (Crypto era)) (Core.Script era), + gsPlutusScripts :: Map (ScriptHash (Crypto era), Tag) (IsValid, Core.Script era), + gsDatums :: Map (DataHash (Crypto era)) (Data era), + gsDPState :: DPState (Crypto era) + } + +deriving instance CC.Crypto c => Show (GenState (BabbageEra c)) + +deriving instance CC.Crypto c => Show (GenState (AlonzoEra c)) + +deriving instance CC.Crypto c => Show (GenState (MaryEra c)) + +deriving instance CC.Crypto c => Show (GenState (AllegraEra c)) + +deriving instance CC.Crypto c => Show (GenState (ShelleyEra c)) + +modifyDPState :: (MonadState (GenState era) m) => (DPState (Crypto era) -> DPState (Crypto era)) -> m () +modifyDPState f = + modify $ \s@GenState {gsDPState = dps} -> s {gsDPState = f dps} + +modifyDState :: (MonadState (GenState era) m) => (DState (Crypto era) -> DState (Crypto era)) -> m () +modifyDState f = + modifyDPState $ \dp@DPState {_dstate = ds} -> dp {_dstate = f ds} + +modifyPState :: (MonadState (GenState era) m) => (PState (Crypto era) -> PState (Crypto era)) -> m () +modifyPState f = + modifyDPState $ \dp@DPState {_pstate = ps} -> dp {_pstate = f ps} + +emptyGenState :: GenState era +emptyGenState = GenState mempty mempty mempty mempty def + +type GenRS era = RWST (GenEnv era) () (GenState era) Gen + +-- | Generate a list of specified length with randomish `ExUnit`s where the sum +-- of all values produced will not exceed the maxTxExUnits. +genExUnits :: Proof era -> Int -> GenRS era [ExUnits] +genExUnits era n = do + GenEnv {gePParams} <- ask + let ExUnits maxMemUnits maxStepUnits = maxTxExUnits' era gePParams + memUnits <- lift $ genSequenceSum maxMemUnits + stepUnits <- lift $ genSequenceSum maxStepUnits + pure $ zipWith ExUnits memUnits stepUnits + where + un = fromIntegral n + genUpTo maxVal (!totalLeft, !acc) _ + | totalLeft == 0 = pure (0, 0 : acc) + | otherwise = do + x <- min totalLeft . round . (% un) <$> genNatural 0 maxVal + pure (totalLeft - x, x : acc) + genSequenceSum maxVal + | maxVal == 0 = pure $ replicate n 0 + | otherwise = snd <$> F.foldlM (genUpTo maxVal) (maxVal, []) [1 .. n] + +lookupScript :: + forall era m. + MonadState (GenState era) m => + ScriptHash (Crypto era) -> + Maybe Tag -> + m (Maybe (Core.Script era)) +lookupScript scriptHash mTag = do + m <- gsScripts <$> get + case Map.lookup scriptHash m of + Just script -> pure $ Just script + Nothing + | Just tag <- mTag -> + Just . snd <$> lookupByKeyM "plutusScript" (scriptHash, tag) gsPlutusScripts + _ -> pure Nothing + +-- | Same as `genCredKeyWit`, but for `TxOuts` +genTxOutKeyWitness :: + forall era. + (Reflect era) => + Proof era -> + Maybe Tag -> + Core.TxOut era -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +genTxOutKeyWitness era mTag txout = do + case (getTxOutAddr txout) of + AddrBootstrap baddr -> + error $ "Can't authorize bootstrap address: " ++ show baddr + Addr _ payCred _ -> (mkWitVKey era mTag payCred) + +genCredKeyWit :: + forall era k. + (Reflect era) => + Proof era -> + Maybe Tag -> + Credential k (Crypto era) -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +genCredKeyWit era mTag cred = mkWitVKey era mTag cred + +-- | Same as `genCredTimelockKeyWit`, but for `TxOuts` +genTxOutTimelockKeyWitness :: + forall era. + (Reflect era) => + Proof era -> + Maybe Tag -> + Core.TxOut era -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> Core.Witnesses era) +genTxOutTimelockKeyWitness era mTag txout = do + case (getTxOutAddr txout) of + AddrBootstrap baddr -> + error $ "Can't authorize bootstrap address: " ++ show baddr + Addr _ payCred _ -> (assembleWits era .) <$> (mkWitVKey era mTag payCred) + +-- | Generator for witnesses necessary for Scripts and Key +-- credentials. Because of the Key credentials generating function requires a body +-- hash for an acutal witness to be constructed. In order to be able to estimate +-- fees and collateral needed we will use produced witness generators twice: one +-- time with bogus body hash for estimation, and the second time with an actual +-- body hash. +genCredTimelockKeyWit :: + forall era k. + (Reflect era) => + Proof era -> + Maybe Tag -> + Credential k (Crypto era) -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> Core.Witnesses era) +genCredTimelockKeyWit era mTag cred = + do + f <- mkWitVKey era mTag cred + pure (assembleWits era . f) + +-- | Generate a Witnesses producing function. We handle Witnesses come from Keys and Scripts +-- Because scripts vary be Era, we need some Era specific code here: genGenericScriptWitness +mkWitVKey :: + forall era kr. + (Reflect era) => + Proof era -> + Maybe Tag -> + Credential kr (Crypto era) -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +mkWitVKey _ _mTag (KeyHashObj keyHash) = do + keyPair <- lookupByKeyM "credential" (coerceKeyRole keyHash) gsKeys + pure $ \bodyHash -> [AddrWits' [makeWitnessVKey bodyHash keyPair]] +mkWitVKey era mTag (ScriptHashObj scriptHash) = + lookupScript @era scriptHash mTag >>= \case + Nothing -> + error $ "Impossible: Cannot find script with hash " ++ show scriptHash + Just script -> do + let scriptWit = [ScriptWits' [script]] + otherWit <- genGenericScriptWitness era mTag script + pure (\hash -> (scriptWit ++ otherWit hash)) + +genGenericScriptWitness :: + (Reflect era) => + Proof era -> + Maybe Tag -> + Core.Script era -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +genGenericScriptWitness (Shelley c) mTag timelock = mkMultiSigWit (Shelley c) mTag timelock +genGenericScriptWitness (Allegra c) mTag timelock = mkTimelockWit (Allegra c) mTag timelock +genGenericScriptWitness (Mary c) mTag timelock = mkTimelockWit (Mary c) mTag timelock +genGenericScriptWitness (Alonzo c) mTag (TimelockScript timelock) = mkTimelockWit (Alonzo c) mTag timelock +genGenericScriptWitness (Alonzo _) _ (PlutusScript _ _) = pure (const []) +genGenericScriptWitness (Babbage c) mTag (TimelockScript timelock) = mkTimelockWit (Babbage c) mTag timelock +genGenericScriptWitness (Babbage _) _ (PlutusScript _ _) = pure (const []) + +-- | Used in Aonzo and Babbage and Mary Eras +mkTimelockWit :: + forall era. + (Reflect era) => + Proof era -> + Maybe Tag -> + Timelock (Crypto era) -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +mkTimelockWit era mTag = + \case + RequireSignature keyHash -> mkWitVKey era mTag (KeyHashObj keyHash) + RequireAllOf timelocks -> F.fold <$> mapM (mkTimelockWit era mTag) timelocks + RequireAnyOf timelocks + | F.null timelocks -> pure (const []) + | otherwise -> mkTimelockWit era mTag =<< lift (elements (F.toList timelocks)) + RequireMOf m timelocks -> do + ts <- take m <$> lift (shuffle (F.toList timelocks)) + F.fold <$> mapM (mkTimelockWit era mTag) ts + RequireTimeStart _ -> pure (const []) + RequireTimeExpire _ -> pure (const []) + +-- | Used in Shelley Eras +mkMultiSigWit :: + forall era. + (Reflect era) => + Proof era -> + Maybe Tag -> + Shelley.MultiSig (Crypto era) -> + GenRS era (SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]) +mkMultiSigWit era mTag (Shelley.RequireSignature keyHash) = mkWitVKey era mTag (KeyHashObj keyHash) +mkMultiSigWit era mTag (Shelley.RequireAllOf timelocks) = F.fold <$> mapM (mkMultiSigWit era mTag) timelocks +mkMultiSigWit era mTag (Shelley.RequireAnyOf timelocks) + | F.null timelocks = pure (const []) + | otherwise = mkMultiSigWit era mTag =<< lift (elements (F.toList timelocks)) +mkMultiSigWit era mTag (Shelley.RequireMOf m timelocks) = do + ts <- take m <$> lift (shuffle (F.toList timelocks)) + F.fold <$> mapM (mkMultiSigWit era mTag) ts + +makeDatumWitness :: Proof era -> Core.TxOut era -> GenRS era [WitnessesField era] +makeDatumWitness proof txout = case (proof, txout) of -- (TxOut _ _ mDatum) = mkDatumWit mDatum + (Babbage _, Babbage.TxOut _ _ (Babbage.DatumHash h) _) -> mkDatumWit (SJust h) + (Babbage _, Babbage.TxOut _ _ (Babbage.Datum bd) _) -> pure [DataWits' [binaryDataToData bd]] + (Babbage _, Babbage.TxOut _ _ Babbage.NoDatum _) -> pure [] + (Alonzo _, TxOut _ _ mDatum) -> mkDatumWit mDatum + _ -> pure [] -- No other era has data witnesses + where + mkDatumWit SNothing = pure [] + mkDatumWit (SJust datumHash) = do + datum <- lookupByKeyM "datum" datumHash gsDatums + pure $ [DataWits' [datum]] + +genKeyHash :: Reflect era => GenRS era (KeyHash kr (Crypto era)) +genKeyHash = do + keyPair <- lift arbitrary + let keyHash = hashKey $ vKey keyPair + modify $ \ts@GenState {gsKeys} -> ts {gsKeys = Map.insert keyHash keyPair gsKeys} + pure $ coerceKeyRole keyHash + +genTimelockScript :: forall era. Reflect era => Proof era -> GenRS era (ScriptHash (Crypto era)) +genTimelockScript proof = do + GenEnv {geValidityInterval = ValidityInterval mBefore mAfter} <- ask + -- We need to limit how deep these timelocks can go, otherwise this generator will + -- diverge. It also has to stay very shallow because it grows too fast. + let genNestedTimelock k + | k > 0 = + elementsT $ + nonRecTimelocks ++ [requireAllOf k, requireAnyOf k, requireMOf k] + | otherwise = elementsT nonRecTimelocks + nonRecTimelocks = + [ r + | SJust r <- + [ SJust requireSignature, + requireTimeStart <$> mBefore, + requireTimeExpire <$> mAfter + ] + ] + requireSignature = RequireSignature <$> genKeyHash + requireAllOf k = do + NonNegative (Small n) <- lift arbitrary + RequireAllOf . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1)) + requireAnyOf k = do + Positive (Small n) <- lift arbitrary + RequireAnyOf . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1)) + requireMOf k = do + NonNegative (Small n) <- lift arbitrary + m <- lift $ choose (0, n) + RequireMOf m . Seq.fromList <$> replicateM n (genNestedTimelock (k - 1)) + requireTimeStart (SlotNo validFrom) = do + minSlotNo <- lift $ choose (minBound, validFrom) + pure $ RequireTimeStart (SlotNo minSlotNo) + requireTimeExpire (SlotNo validTill) = do + maxSlotNo <- lift $ choose (validTill, maxBound) + pure $ RequireTimeExpire (SlotNo maxSlotNo) + tlscript <- genNestedTimelock (2 :: Natural) + let corescript :: Core.Script era + corescript = case proof of + Babbage _ -> TimelockScript tlscript + Alonzo _ -> TimelockScript tlscript + Mary _ -> tlscript + Allegra _ -> tlscript + Shelley _ -> error "Shelley does not have TimeLock scripts" + let scriptHash = hashScript @era corescript + modify $ \ts@GenState {gsScripts} -> ts {gsScripts = Map.insert scriptHash corescript gsScripts} + pure scriptHash + +genMultiSigScript :: forall era. Reflect era => Proof era -> GenRS era (ScriptHash (Crypto era)) +genMultiSigScript proof = do + let genNestedMultiSig k + | k > 0 = + elementsT $ + nonRecTimelocks ++ [requireAllOf k, requireAnyOf k, requireMOf k] + | otherwise = elementsT nonRecTimelocks + nonRecTimelocks = [requireSignature] + requireSignature = Shelley.RequireSignature <$> genKeyHash + requireAllOf k = do + NonNegative (Small n) <- lift arbitrary + Shelley.RequireAllOf <$> replicateM n (genNestedMultiSig (k - 1)) + requireAnyOf k = do + Positive (Small n) <- lift arbitrary + Shelley.RequireAnyOf <$> replicateM n (genNestedMultiSig (k - 1)) + requireMOf k = do + NonNegative (Small n) <- lift arbitrary + m <- lift $ choose (0, n) + Shelley.RequireMOf m <$> replicateM n (genNestedMultiSig (k - 1)) + msscript <- genNestedMultiSig (2 :: Natural) + let corescript :: Core.Script era + corescript = case proof of + Shelley _ -> msscript + _ -> error (show proof ++ " does not have MultiSig scripts") + let scriptHash = hashScript @era corescript + modify $ \ts@GenState {gsScripts} -> ts {gsScripts = Map.insert scriptHash corescript gsScripts} + pure scriptHash + +genPlutusScript :: forall era. Reflect era => Proof era -> Tag -> GenRS era (ScriptHash (Crypto era)) +genPlutusScript proof tag = do + isValid <- lift $ frequency [(5, pure False), (95, pure True)] + -- Plutus scripts alwaysSucceeds needs at least numArgs, while + -- alwaysFails needs exactly numArgs to have the desired affect. + let numArgs + | tag == Spend = 3 + | otherwise = 2 + -- While using varying number of arguments for alwaysSucceeds we get + -- varying script hashes, which helps with the fuzziness + language <- lift $ elements (Set.toList nonNativeLanguages) + script <- + if isValid + then alwaysSucceeds @era language . (+ numArgs) . getNonNegative <$> lift arbitrary + else pure $ alwaysFails @era language numArgs + let corescript :: Core.Script era + corescript = case proof of + Alonzo _ -> script + Babbage _ -> script + _ -> error ("Only Alonzo and Babbage have PlutusScripts. " ++ show proof ++ " does not.") + scriptHash = hashScript @era corescript + modify $ \ts@GenState {gsPlutusScripts} -> + ts {gsPlutusScripts = Map.insert (scriptHash, tag) (IsValid isValid, corescript) gsPlutusScripts} + pure scriptHash + +genScript :: forall era. Reflect era => Proof era -> Tag -> GenRS era (ScriptHash (Crypto era)) +genScript proof tag = case proof of + Babbage _ -> elementsT [genTimelockScript proof, genPlutusScript proof tag] + Alonzo _ -> elementsT [genTimelockScript proof, genPlutusScript proof tag] + Mary _ -> genTimelockScript proof + Allegra _ -> genTimelockScript proof + Shelley _ -> genMultiSigScript proof + +paymentCredAddr :: Addr c -> Maybe (Credential 'Payment c) +paymentCredAddr (Addr _ cred _) = Just cred +paymentCredAddr _ = Nothing + +stakeCredAddr :: Addr c -> Maybe (Credential 'Staking c) +stakeCredAddr (Addr _ _ (StakeRefBase cred)) = Just cred +stakeCredAddr _ = Nothing + +lookupPlutusScript :: + (MonadState (GenState era) m) => + Credential k (Crypto era) -> + Tag -> + m (Maybe (IsValid, ScriptHash (Crypto era))) +lookupPlutusScript (KeyHashObj _) _ = pure Nothing +lookupPlutusScript (ScriptHashObj scriptHash) tag = + fmap (Map.lookup (scriptHash, tag) . gsPlutusScripts) get <&> \case + Nothing -> Nothing + Just (isValid, _) -> Just (isValid, scriptHash) + +redeemerWitnessMaker :: + Era era => + Tag -> + [Maybe (GenRS era (Data era), Credential k (Crypto era))] -> + GenRS era (IsValid, [ExUnits -> [WitnessesField era]]) +redeemerWitnessMaker tag listWithCred = + let creds = + [ (ix, genDat, cred) + | (ix, mCred) <- zip [0 ..] listWithCred, + Just (genDat, cred) <- [mCred] + ] + allValid = IsValid . getAll . foldMap (\(IsValid v) -> All v) + in fmap (first allValid . unzip . catMaybes) $ + forM creds $ \(ix, genDat, cred) -> + lookupPlutusScript cred tag >>= \case + Nothing -> pure Nothing + Just (isValid, _) -> do + datum <- genDat + let rPtr = RdmrPtr tag ix + mkWit exUnits = [RdmrWits (Redeemers $ Map.singleton rPtr (datum, exUnits))] + pure $ Just (isValid, mkWit) + +-- | Collaterals can't have scripts, this is where this generator is needed. +genNoScriptRecipient :: Reflect era => GenRS era (Addr (Crypto era)) +genNoScriptRecipient = do + paymentCred <- KeyHashObj <$> genKeyHash + stakeCred <- StakeRefBase . KeyHashObj <$> genKeyHash + pure (Addr Testnet paymentCred stakeCred) + +-- | Generate a credential that can be used for supplied purpose (in case of +-- plutus scripts), while occasionally picking out randomly from previously +-- generated set. +genCredential :: Reflect era => Tag -> GenRS era (Credential kr (Crypto era)) +genCredential tag = + frequencyT + [ (35, KeyHashObj <$> genKeyHash), + (35, ScriptHashObj <$> genScript reify tag), + (10, pickExistingKeyHash), + (20, pickExistingScript) + ] + where + pickExistingKeyHash = + KeyHashObj <$> do + keysMap <- gsKeys <$> get + lift (genMapElem keysMap) >>= \case + Just (k, _) -> pure $ coerceKeyRole k + Nothing -> genKeyHash + pickExistingScript = + ScriptHashObj + <$> elementsT [pickExistingPlutusScript, pickExistingTimelockScript] + pickExistingPlutusScript = do + plutusScriptsMap <- + Map.filterWithKey (\(_, t) _ -> t == tag) . gsPlutusScripts <$> get + lift (genMapElem plutusScriptsMap) >>= \case + Just ((h, _), _) -> pure h + Nothing -> genScript reify tag + pickExistingTimelockScript = do + timelockScriptsMap <- gsScripts <$> get + lift (genMapElem timelockScriptsMap) >>= \case + Just (h, _) -> pure h + Nothing -> genScript reify tag + +genRecipient :: Reflect era => GenRS era (Addr (Crypto era)) +genRecipient = do + paymentCred <- genCredential Spend + stakeCred <- genCredential Cert + pure (Addr Testnet paymentCred (StakeRefBase stakeCred)) + +genDatum :: Era era => GenRS era (Data era) +genDatum = snd <$> genDatumWithHash + +genDatumWithHash :: Era era => GenRS era (DataHash (Crypto era), Data era) +genDatumWithHash = do + datum <- lift arbitrary + let datumHash = hashData datum + modify $ \ts@GenState {gsDatums} -> ts {gsDatums = Map.insert datumHash datum gsDatums} + pure (datumHash, datum) + +genTxOut :: Reflect era => Proof era -> Core.Value era -> GenRS era [TxOutField era] +genTxOut proof val = do + addr <- genRecipient + cred <- maybe (error "BootstrapAddress encountered") pure $ paymentCredAddr addr + dataHashFields <- + case cred of + KeyHashObj _ -> pure [] + ScriptHashObj scriptHash -> do + maybecorescript <- lookupScript scriptHash (Just Spend) + case (proof, maybecorescript) of + (Babbage _, Just (PlutusScript _ _)) -> do + (datahash, _data) <- genDatumWithHash + pure [DHash' [datahash]] + (Alonzo _, Just (PlutusScript _ _)) -> do + (datahash, _data) <- genDatumWithHash + pure [DHash' [datahash]] + (_, _) -> pure [] + pure $ [Address addr, Amount val] ++ dataHashFields + +genUTxO :: Reflect era => GenRS era (UTxO era) +genUTxO = do + NonEmpty ins <- lift $ resize 10 arbitrary + UTxO <$> sequence (SplitMap.fromSet (const genOut) (Set.fromList ins)) + where + genOut = do + val <- lift genPositiveVal + fields <- genTxOut reify val + pure (coreTxOut reify fields) + +genPool :: Reflect era => GenRS era (KeyHash 'StakePool (Crypto era)) +genPool = frequencyT [(10, genNewPool), (90, pickExisting)] + where + pickExisting = do + DPState {_pstate = PState {_pParams}} <- gsDPState <$> get + lift (genMapElem _pParams) >>= \case + Nothing -> genNewPool + Just poolId -> pure $ fst poolId + genNewPool = do + poolId <- genKeyHash + pp <- genPoolParams poolId + modifyPState $ \ps -> ps {_pParams = Map.insert poolId pp (_pParams ps)} + pure poolId + genPoolParams _poolId = do + _poolVrf <- lift arbitrary + _poolPledge <- lift genPositiveVal + _poolCost <- lift genPositiveVal + _poolMargin <- lift arbitrary + _poolRAcnt <- RewardAcnt Testnet <$> genCredential Rewrd + let _poolOwners = mempty + let _poolRelays = mempty + let _poolMD = SNothing + pure PoolParams {..} + +genDCert :: Reflect era => GenRS era (DCert (Crypto era)) +genDCert = + elementsT + [ DCertDeleg + <$> elementsT + [ RegKey <$> genCredential Cert, + DeRegKey <$> genCredential Cert, + Delegate <$> genDelegation + ] + ] + where + genDelegation = do + rewardAccount <- genCredential Cert + poolId <- genPool + pure $ Delegation {_delegator = rewardAccount, _delegatee = poolId} + +genDCerts :: Reflect era => GenRS era [DCert (Crypto era)] +genDCerts = do + let genUniqueScript (!dcs, !ss, !regCreds) _ = do + dc <- genDCert + -- Workaround a misfeature where duplicate plutus scripts in DCert are ignored + let insertIfNotPresent dcs' regCreds' mKey mScriptHash + | Just (_, scriptHash) <- mScriptHash = + if (scriptHash, mKey) `Set.member` ss + then (dcs, ss, regCreds) + else (dc : dcs', Set.insert (scriptHash, mKey) ss, regCreds') + | otherwise = (dc : dcs', ss, regCreds') + -- Generate registration and de-registration delegation certificates, + -- while ensuring the proper registered/unregestered state in DState + case dc of + DCertDeleg d + | RegKey regCred <- d -> + if regCred `Set.member` regCreds + then pure (dcs, ss, regCreds) + else pure (dc : dcs, ss, Set.insert regCred regCreds) + | DeRegKey deregCred <- d -> + if deregCred `Set.member` regCreds + then + insertIfNotPresent dcs (Set.delete deregCred regCreds) Nothing + <$> lookupPlutusScript deregCred Cert + else pure (dcs, ss, regCreds) + | Delegate (Delegation delegCred delegKey) <- d -> + let (dcs', regCreds') + | delegCred `Set.member` regCreds = (dcs, regCreds) + | otherwise = + (DCertDeleg (RegKey delegCred) : dcs, Set.insert delegCred regCreds) + in insertIfNotPresent dcs' regCreds' (Just delegKey) + <$> lookupPlutusScript delegCred Cert + _ -> pure (dc : dcs, ss, regCreds) + NonNegative n <- lift arbitrary + DPState {_dstate = DState {_unified}} <- gsDPState <$> get + let initSets = ([], Set.empty, UM.domain (Rewards _unified)) + (dcs, _, _) <- F.foldlM genUniqueScript initSets [1 :: Int .. n] + pure $ reverse dcs + +genCollateralUTxO :: + forall era. + (HasCallStack, Reflect era) => + [Addr (Crypto era)] -> + Coin -> + UTxO era -> + GenRS era (UTxO era, Map.Map (TxIn (Crypto era)) (Core.TxOut era)) +genCollateralUTxO collateralAddresses (Coin fee) (UTxO utxo) = do + GenEnv {gePParams} <- ask + let collPerc = collateralPercentage' reify gePParams + minCollTotal = Coin (ceiling ((fee * toInteger collPerc) % 100)) + -- Generate a collateral that is neither in UTxO map nor has already been generated + genNewCollateral addr coll um c = do + -- The size of the Gen computation is driven down when we generate scripts, so it can be 0 here + -- that is really bad, because if the happens we get the same TxIn every time, and 'coll' never grows, + -- so this function doesn't terminate. We want many choices of TxIn, so resize just this arbitrary by 10. + txIn <- lift (resize 10 (arbitrary :: Gen (TxIn (Crypto era)))) + if SplitMap.member txIn utxo || Map.member txIn coll + then genNewCollateral addr coll um c + else pure (um, Map.insert txIn (coreTxOut reify [Address addr, Amount (inject c)]) coll, c) + -- Either pick a collateral from a map or generate a completely new one + genCollateral addr coll um + | Map.null um = genNewCollateral addr coll um =<< lift genPositiveVal + | otherwise = do + i <- lift $ chooseInt (0, Map.size um - 1) + let (txIn, txOut) = Map.elemAt i um + val = getTxOutVal reify txOut + pure (Map.deleteAt i um, Map.insert txIn txOut coll, coin val) + -- Recursively either pick existing key spend only outputs or generate new ones that + -- will be later added to the UTxO map + go :: + [Addr (Crypto era)] -> + Map (TxIn (Crypto era)) (Core.TxOut era) -> + Coin -> + Map (TxIn (Crypto era)) (Core.TxOut era) -> + GenRS era (Map (TxIn (Crypto era)) (Core.TxOut era)) + go ecs !coll !curCollTotal !um + | curCollTotal >= minCollTotal = pure coll + | [] <- ecs = error "Impossible: supplied less addresses then `maxCollateralInputs`" + | ec : ecs' <- ecs = do + (um', coll', c) <- + if null ecs' + then genNewCollateral ec coll um (minCollTotal <-> curCollTotal) + else elementsT [genCollateral ec coll Map.empty, genCollateral ec coll um] + go ecs' coll' (curCollTotal <+> c) um' + collaterals <- + go collateralAddresses Map.empty (Coin 0) $ + SplitMap.toMap $ SplitMap.filter spendOnly utxo + pure (UTxO (Map.foldrWithKey' SplitMap.insert utxo collaterals), collaterals) + +spendOnly :: Era era => Core.TxOut era -> Bool +spendOnly txout = case getTxOutAddr txout of + (Addr _ (ScriptHashObj _) _) -> False + (Addr _ _ (StakeRefBase (ScriptHashObj _))) -> False + _ -> True + +genUTxOState :: forall era. Reflect era => UTxO era -> GenRS era (UTxOState era) +genUTxOState utxo = do + GenEnv {gePParams} <- ask + DPState {_dstate, _pstate} <- gsDPState <$> get + let deposited = obligation' reify gePParams (rewards _dstate) (_pParams _pstate) + lift (UTxOState utxo deposited <$> arbitrary <*> pure (emptyPPUPstate @era reify) <*> pure def) + +genRecipientsFrom :: Reflect era => [Core.TxOut era] -> GenRS era [Core.TxOut era] +genRecipientsFrom txOuts = do + let outCount = length txOuts + approxCount <- lift $ choose (1, outCount) + let extra = outCount - approxCount + avgExtra = ceiling (toInteger extra % toInteger approxCount) + genExtra e + | e <= 0 || avgExtra == 0 = pure 0 + | otherwise = lift $ chooseInt (0, avgExtra) + let goNew _ [] !rs = pure rs + goNew e (tx : txs) !rs = do + leftToAdd <- genExtra e + goExtra (e - leftToAdd) leftToAdd (inject (Coin 0)) tx txs rs + goExtra _ _ s tx [] !rs = genWithChange s tx rs + goExtra e 0 s tx txs !rs = goNew e txs =<< genWithChange s tx rs + goExtra e n s txout (tx : txs) !rs = goExtra e (n - 1) (s <+> v) tx txs rs + where + v = getTxOutVal reify txout + genWithChange s txout rs = do + let (!addr, !v, !ds) = txoutFields reify txout + c <- Coin <$> lift (choose (1, unCoin $ coin v)) + fields <- genTxOut reify (s <+> inject c) + if c < coin v + then + let !change = coreTxOut reify ([Address addr, Amount (v <-> inject c)] ++ ds) + in pure (coreTxOut reify fields : change : rs) + else pure (coreTxOut reify fields : rs) + goNew extra txOuts [] + +getDCertCredential :: DCert crypto -> Maybe (Credential 'Staking crypto) +getDCertCredential = \case + DCertDeleg d -> + case d of + RegKey _rk -> Nothing -- we don't require witnesses for RegKey + DeRegKey drk -> Just drk + Delegate (Delegation dk _) -> Just dk + DCertPool _p -> Nothing + DCertGenesis _g -> Nothing + DCertMir _m -> Nothing + +genRewards :: Reflect era => GenRS era (RewardAccounts (Crypto era)) +genRewards = do + NonNegative n <- lift arbitrary + newrewards <- + Map.fromList <$> replicateM n ((,) <$> genCredential Rewrd <*> lift genPositiveVal) + modifyDState $ \ds -> ds {_unified = rewards ds UM.⨃ newrewards} -- Prefers coins in newrewards + pure newrewards + +genWithdrawals :: Reflect era => GenRS era (Wdrl (Crypto era)) +genWithdrawals = do + let networkId = Testnet + newrewards <- genRewards + pure $ Wdrl $ Map.fromList $ map (first (RewardAcnt networkId)) $ Map.toList newrewards + +languagesUsed :: + forall era. + Era era => + Proof era -> + Core.Tx era -> + UTxO era -> + Map (ScriptHash (Crypto era), Tag) (IsValid, Core.Script era) -> + Set Language +languagesUsed proof tx utxo plutusScripts = case proof of + (Shelley _) -> Set.empty + (Allegra _) -> Set.empty + (Mary _) -> Set.empty + (Alonzo _) -> Set.fromList [lang | (_, PlutusScript lang _) <- mapMaybe lookupPlutus needed] + where + needed = scriptsNeeded @era utxo tx + (Babbage _) -> Set.fromList [lang | (_, PlutusScript lang _) <- mapMaybe lookupPlutus needed] + where + needed = scriptsNeeded @era utxo tx -- TODO FIXME, Not sure this is the right function for Babbage + where + lookupPlutus :: (ScriptPurpose (Crypto era), ScriptHash (Crypto era)) -> Maybe (IsValid, Core.Script era) + lookupPlutus ((Spending _), sh) = Map.lookup (sh, Spend) plutusScripts + lookupPlutus ((Rewarding _), sh) = Map.lookup (sh, Rewrd) plutusScripts + lookupPlutus ((Certifying _), sh) = Map.lookup (sh, Cert) plutusScripts + lookupPlutus ((Minting _), sh) = Map.lookup (sh, Mint) plutusScripts + +timeToLive :: ValidityInterval -> SlotNo +timeToLive (ValidityInterval _ (SJust n)) = n +timeToLive (ValidityInterval _ SNothing) = SlotNo maxBound + +genValidatedTx :: forall era. Reflect era => Proof era -> GenRS era (UTxO era, Core.Tx era) +genValidatedTx proof = do + GenEnv {geValidityInterval, gePParams} <- ask + UTxO utxoNoCollateral <- genUTxO + -- 1. Produce utxos that will be spent + n <- lift $ choose (1, length utxoNoCollateral) + toSpendNoCollateral <- + Map.fromList . take n <$> lift (shuffle $ SplitMap.toList utxoNoCollateral) + -- 2. Check if all Plutus scripts are valid + let toSpendNoCollateralTxOuts :: [Core.TxOut era] + toSpendNoCollateralTxOuts = Map.elems toSpendNoCollateral + -- We use maxBound to ensure the serializaed size overestimation + maxCoin = Coin (toInteger (maxBound :: Int)) + -- 3. Generate all recipients and witnesses needed for spending Plutus scripts + recipients <- genRecipientsFrom toSpendNoCollateralTxOuts + (IsValid v1, mkPaymentWits) <- -- mkPaymentWits :: ExUnits -> [WitnessField] + redeemerWitnessMaker + Spend + [ (\dh c -> (lookupByKeyM "datum" dh gsDatums, c)) + <$> mDatumHash + <*> paymentCredAddr addr + | (_, coretxout) <- Map.toAscList toSpendNoCollateral, + let (addr, mDatumHash) = txoutAddrHash proof coretxout + ] + + wdrls@(Wdrl wdrlMap) <- genWithdrawals + rewardsWithdrawalTxOut <- coreTxOut proof <$> (genTxOut proof $ inject $ F.fold wdrlMap) + let wdrlCreds = map (getRwdCred . fst) $ Map.toAscList wdrlMap + (IsValid v2, mkWdrlWits) <- + redeemerWitnessMaker Rewrd $ map (Just . (,) genDatum) wdrlCreds + dcerts <- genDCerts + let dcertCreds = map getDCertCredential dcerts + (IsValid v3, mkCertsWits) <- + redeemerWitnessMaker Cert $ map ((,) genDatum <$>) dcertCreds + + let isValid = IsValid (v1 && v2 && v3) + mkWits :: [ExUnits -> [WitnessesField era]] + mkWits = mkPaymentWits ++ mkCertsWits ++ mkWdrlWits + exUnits <- genExUnits proof (length mkWits) + + let redeemerWitsList = concat (zipWith ($) mkWits exUnits) + datumWitsList <- concat <$> mapM (makeDatumWitness proof) (Map.elems toSpendNoCollateral) + keyWitsMakers <- mapM (genTxOutKeyWitness proof (Just Spend)) toSpendNoCollateralTxOuts + dcertWitsMakers <- mapM (genCredKeyWit proof (Just Cert)) $ catMaybes dcertCreds + rwdrsWitsMakers <- mapM (genCredKeyWit proof (Just Rewrd)) wdrlCreds + + -- 4. Estimate inputs that will be used as collateral + maxCollateralCount <- + lift $ chooseInt (1, fromIntegral (maxCollateralInputs' proof gePParams)) + bogusCollateralTxId <- lift (arbitrary :: Gen (TxId (Crypto era))) + let bogusCollateralTxIns = + Set.fromList + [ TxIn bogusCollateralTxId (mkTxIxPartial (fromIntegral i)) + | i <- [1 .. 10 :: Int] -- [maxBound, maxBound - 1 .. maxBound - maxCollateralCount - 1] + ] + collateralAddresses <- replicateM maxCollateralCount genNoScriptRecipient + bogusCollateralKeyWitsMakers <- + mapM (\a -> genTxOutKeyWitness proof Nothing (coreTxOut proof [Address a, Amount (inject maxCoin)])) collateralAddresses + networkId <- lift $ elements [SNothing, SJust Testnet] + + -- 5. Estimate the fee + let redeemerDatumWits = (redeemerWitsList ++ datumWitsList) + bogusIntegrityHash = hashScriptIntegrity' proof gePParams mempty (Redeemers mempty) mempty + txBodyNoFee = + coreTxBody + proof + [ Inputs (Map.keysSet (toSpendNoCollateral)), + Collateral bogusCollateralTxIns, + Outputs' (rewardsWithdrawalTxOut : recipients), + Certs' dcerts, + Wdrls wdrls, + Txfee maxCoin, + ifProof proof (postAllegra Mock) (Vldt geValidityInterval) (TTL (timeToLive geValidityInterval)), + Update' [], + ReqSignerHashes' [], + Generic.Mint mempty, + WppHash bogusIntegrityHash, + AdHash' [], + Txnetworkid networkId + ] + txBodyNoFeeHash = hashAnnotated txBodyNoFee + witsMakers :: [SafeHash (Crypto era) EraIndependentTxBody -> [WitnessesField era]] + witsMakers = keyWitsMakers ++ dcertWitsMakers ++ rwdrsWitsMakers + noFeeWits :: [WitnessesField era] + noFeeWits = + redeemerDatumWits + <> foldMap ($ txBodyNoFeeHash) (witsMakers ++ bogusCollateralKeyWitsMakers) + bogusTxForFeeCalc = + coreTx + proof + [ Body txBodyNoFee, + Witnesses (assembleWits proof noFeeWits), + Valid isValid, + AuxData' [] + ] + fee = minfee' proof gePParams bogusTxForFeeCalc + + -- 6. Crank up the amount in one of outputs to account for the fee. Note this is + -- a hack that is not possible in a real life, but in the end it does produce + -- real life like setup + feeKey <- lift $ elements $ Map.keys toSpendNoCollateral + let utxoFeeAdjusted = + UTxO $ case SplitMap.lookup feeKey utxoNoCollateral of + Nothing -> utxoNoCollateral + Just txOut -> SplitMap.insert feeKey (injectFee proof fee txOut) utxoNoCollateral + + -- 7. Generate utxos that will be used as collateral + (utxo, collMap) <- genCollateralUTxO collateralAddresses fee utxoFeeAdjusted + collateralKeyWitsMakers <- mapM (genTxOutKeyWitness proof Nothing) $ Map.elems collMap + + -- 8. Construct the correct Tx with valid fee and collaterals + allPlutusScripts <- gsPlutusScripts <$> get + let mIntegrityHash = + hashScriptIntegrity' + proof + gePParams + (languagesUsed proof bogusTxForFeeCalc (UTxO utxoNoCollateral) allPlutusScripts) + (mkTxrdmrs redeemerDatumWits) + (mkTxdats redeemerDatumWits) + txBody = + overrideTxBody + proof + txBodyNoFee + [ Txfee fee, + Collateral (Map.keysSet collMap), + WppHash mIntegrityHash + ] + txBodyHash = hashAnnotated txBody + wits = + redeemerDatumWits + <> foldMap ($ txBodyHash) (witsMakers ++ collateralKeyWitsMakers) + validTx = coreTx proof [Body txBody, Witnesses (assembleWits proof wits), Valid isValid, AuxData' []] + pure (utxo, validTx) + +-- | Scan though the fields unioning all the RdrmWits fields into one Redeemer map +mkTxrdmrs :: forall era. Era era => [WitnessesField era] -> Redeemers era +mkTxrdmrs fields = Redeemers (List.foldl' accum Map.empty fields) + where + accum m1 (RdmrWits (Redeemers m2)) = Map.union m1 m2 + accum m1 _ = m1 + +-- | Scan though the fields unioning all the DataWits fields into one TxDat +mkTxdats :: forall era. Era era => [WitnessesField era] -> TxDats era +mkTxdats fields = TxDats (List.foldl' accum Map.empty fields) + where + accum m (DataWits' ds) = (List.foldl' accum2 m ds) + where + accum2 m2 d = Map.insert (hashData @era d) d m2 + accum m _ = m + +-- ======================================================= +-- An encapsulation of the Top level types we generate, +-- but that has its own Show instance that we can control. + +data Box era = Box (TRC (Core.EraRule "LEDGER" era)) (GenState era) + +instance + ( Era era, + PrettyA (State (Core.EraRule "LEDGER" era)), + PrettyA (Core.Script era), + PrettyA (Signal (Core.EraRule "LEDGER" era)) + ) => + Show (Box era) + where + show (Box (TRC (_env, _state, sig)) _gs) = + show $ + ppRecord + "Box" + [ ("Tx", prettyA sig) + -- , ("TRC state",prettyA _state) + -- , ("GenEnv",ppGenState _gs) + ] + +ppGenState :: (CC.Crypto (Crypto era), PrettyA (Core.Script era)) => GenState era -> PDoc +ppGenState (GenState keys scripts plutus dats dp) = + ppRecord + "GenState" + [ ("Keymap", ppMap ppKeyHash (dotsF ppKeyPair) keys), + ("Scriptmap", ppMap ppScriptHash prettyA scripts), + ( "PlutusScripts", + ppMap + (ppPair ppScriptHash ppTag) + (ppPair ppIsValid prettyA) + plutus + ), + ("Datums", dots $ ppMap ppSafeHash ppData dats), + ("DPState", dots $ ppDPState dp) + ] + +-- ===================================== +-- Now the Top level generators + +genTxAndUTXOState :: Reflect era => Proof era -> Gen (TRC (Core.EraRule "UTXOW" era), GenState era) +genTxAndUTXOState proof@(Babbage _) = do + (Box (TRC (LedgerEnv slotNo _ pp _, (utxoState, _), vtx)) genState) <- genTxAndLEDGERState proof + pure (TRC (UtxoEnv slotNo pp mempty (GenDelegs mempty), utxoState, vtx), genState) +genTxAndUTXOState proof@(Alonzo _) = do + (Box (TRC (LedgerEnv slotNo _ pp _, (utxoState, _), vtx)) genState) <- genTxAndLEDGERState proof + pure (TRC (UtxoEnv slotNo pp mempty (GenDelegs mempty), utxoState, vtx), genState) +genTxAndUTXOState proof@(Mary _) = do + (Box (TRC (LedgerEnv slotNo _ pp _, (utxoState, _), vtx)) genState) <- genTxAndLEDGERState proof + pure (TRC (UtxoEnv slotNo pp mempty (GenDelegs mempty), utxoState, vtx), genState) +genTxAndUTXOState proof@(Allegra _) = do + (Box (TRC (LedgerEnv slotNo _ pp _, (utxoState, _), vtx)) genState) <- genTxAndLEDGERState proof + pure (TRC (UtxoEnv slotNo pp mempty (GenDelegs mempty), utxoState, vtx), genState) +genTxAndUTXOState proof@(Shelley _) = do + (Box (TRC (LedgerEnv slotNo _ pp _, (utxoState, _), vtx)) genState) <- genTxAndLEDGERState proof + pure (TRC (UtxoEnv slotNo pp mempty (GenDelegs mempty), utxoState, vtx), genState) + +genTxAndLEDGERState :: + ( Reflect era, + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era, + State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), + Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era + ) => + Proof era -> + Gen (Box era) +genTxAndLEDGERState proof = do + txIx <- arbitrary + maxTxExUnits <- (arbitrary :: Gen ExUnits) + Positive maxCollateralInputs <- (arbitrary :: Gen (Positive Natural)) + collateralPercentage <- (fromIntegral <$> chooseInt (1, 10000)) :: Gen Natural + minfeeA <- fromIntegral <$> chooseInt (0, 1000) + minfeeB <- fromIntegral <$> chooseInt (0, 10000) + -- (env,pp) <- setup proof -- Generate a PParams and a GenEnv + let genT = do + (utxo, tx) <- genValidatedTx proof + utxoState <- genUTxOState utxo + dpState <- gsDPState <$> get + pure $ TRC (ledgerEnv, (utxoState, dpState), tx) + pp = + newPParams + proof + [ MinfeeA minfeeA, + MinfeeB minfeeB, + Costmdls $ + Map.fromList + [ (PlutusV1, CostModel $ 0 <$ fromJust defaultCostModelParams), + (PlutusV2, CostModel $ 0 <$ fromJust defaultCostModelParams) + ], + MaxValSize 1000, + MaxTxSize $ fromIntegral (maxBound :: Int), + MaxTxExUnits maxTxExUnits, + MaxCollateralInputs maxCollateralInputs, + CollateralPercentage collateralPercentage + ] + slotNo = SlotNo 100000000 + ledgerEnv = LedgerEnv slotNo txIx pp (AccountState (Coin 0) (Coin 0)) + minSlotNo <- oneof [pure SNothing, SJust <$> choose (minBound, unSlotNo slotNo)] + maxSlotNo <- oneof [pure SNothing, SJust <$> choose (unSlotNo slotNo + 1, maxBound)] + let env = + GenEnv + { geValidityInterval = ValidityInterval (SlotNo <$> minSlotNo) (SlotNo <$> maxSlotNo), + gePParams = pp + } + (trc, s, _) <- runRWST genT env emptyGenState + pure (Box trc s) + +-- ============================================================================== +-- How we take the generated stuff and put it through the STS rule mechanism +-- in a way that is Era Agnostic + +applySTSByProof :: + (RuleTypeRep rtype, GoodCrypto (Crypto era)) => + Proof era -> + RuleContext rtype (Core.EraRule "LEDGER" era) -> + (Either [PredicateFailure (Core.EraRule "LEDGER" era)] (State (Core.EraRule "LEDGER" era))) +applySTSByProof (Babbage _) trc = runShelleyBase $ applySTS trc +applySTSByProof (Alonzo _) trc = runShelleyBase $ applySTS trc +applySTSByProof (Mary _) trc = runShelleyBase $ applySTS trc +applySTSByProof (Allegra _) trc = runShelleyBase $ applySTS trc +applySTSByProof (Shelley _) trc = runShelleyBase $ applySTS trc + +-- ============================================= +-- Now a test + +totalAda :: Reflect era => UTxOState era -> DPState (Crypto era) -> Coin +totalAda (UTxOState utxo f d _ _) DPState {_dstate} = + f <> d <> coin (balance utxo) <> F.foldl' (<>) mempty (rewards _dstate) + +-- Note we could probably abstract over an arbitray test here with +-- type:: Box era -> Core.Tx era -> UTxOState era -> DPState era -> Property + +testTxValidForLEDGER :: + ( Reflect era, + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era, + State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), + PrettyA (PredicateFailure (Core.EraRule "LEDGER" era)) + ) => + Proof era -> + Box era -> + Property +testTxValidForLEDGER proof (Box (trc@(TRC (_, (utxoState, dpstate), vtx))) _) = + case applySTSByProof proof trc of -- trc encodes the initial (generated) state, vtx is the transaction + Right (utxoState', dpstate') -> + -- UTxOState and DPState after applying the transaction + classify (coerce (isValid' proof vtx)) "TxValid" $ + totalAda utxoState' dpstate' === totalAda utxoState dpstate + Left errs -> counterexample (show (ppList prettyA errs)) (property False) + +-- =============================================================== +-- Tools for generating other things from a GenEnv. This way one can +-- test individual functions in this file. + +-- | Make a well formed GenEnv +setup :: Proof era -> Gen (GenEnv era) +setup proof = do + maxTxExUnits <- (arbitrary :: Gen ExUnits) + Positive maxCollateralInputs <- (arbitrary :: Gen (Positive Natural)) + collateralPercentage <- (fromIntegral <$> chooseInt (1, 10000)) :: Gen Natural + minfeeA <- fromIntegral <$> chooseInt (0, 1000) + minfeeB <- fromIntegral <$> chooseInt (0, 10000) + let pp = + newPParams + proof + [ MinfeeA minfeeA, + MinfeeB minfeeB, + Costmdls $ + Map.fromList + [ (PlutusV1, CostModel $ 0 <$ fromJust defaultCostModelParams), + (PlutusV2, CostModel $ 0 <$ fromJust defaultCostModelParams) + ], + MaxValSize 1000, + MaxTxSize $ fromIntegral (maxBound :: Int), + MaxTxExUnits maxTxExUnits, + MaxCollateralInputs maxCollateralInputs, + CollateralPercentage collateralPercentage + ] + slotNo = SlotNo 100000000 + minSlotNo <- oneof [pure SNothing, SJust <$> choose (minBound, unSlotNo slotNo)] + maxSlotNo <- oneof [pure SNothing, SJust <$> choose (unSlotNo slotNo + 1, maxBound)] + let env = + GenEnv + { geValidityInterval = ValidityInterval (SlotNo <$> minSlotNo) (SlotNo <$> maxSlotNo), + gePParams = pp + } + pure (env) + +-- | Construct a random (Gen b) +makeGen :: Proof era -> (Proof era -> GenRS era b) -> Gen b +makeGen proof computeWith = do + env <- setup proof + (ans, _state, _written) <- runRWST (computeWith proof) env emptyGenState + pure ans + +runTest :: PrettyA a => (Proof era -> GenRS era a) -> Proof era -> IO () +runTest computeWith proof = do + ans <- generate (makeGen proof computeWith) + putStrLn (show (prettyA ans)) + +main2 :: IO () +main2 = runTest (\x -> fst <$> genValidatedTx x) (Alonzo Mock) + +-- ============================================= +-- Make some property tests + +-- ========================================================================= +-- The generic types make a roundtrip without adding or losing information + +txOutRoundTrip :: + (Eq (Core.TxOut era), Era era) => Proof era -> Core.TxOut era -> Bool +txOutRoundTrip proof x = coreTxOut proof (abstractTxOut proof x) == x + +txRoundTrip :: + Eq (Core.Tx era) => Proof era -> Core.Tx era -> Bool +txRoundTrip proof x = coreTx proof (abstractTx proof x) == x + +txBodyRoundTrip :: + (Eq (Core.TxBody era), Era era) => Proof era -> Core.TxBody era -> Bool +txBodyRoundTrip proof x = coreTxBody proof (abstractTxBody proof x) == x + +txWitRoundTrip :: + (Eq (Core.Witnesses era), Era era) => Proof era -> Core.Witnesses era -> Bool +txWitRoundTrip proof x = assembleWits proof (abstractWitnesses proof x) == x + +coreTypesRoundTrip :: TestTree +coreTypesRoundTrip = + testGroup + "Core types make generic roundtrips" + [ testGroup + "Witnesses roundtrip" + [ -- testProperty "Babbage era" $ txWitRoundTrip (Babbage Mock), -- No Arbitrary instance yet + testProperty "Alonzo era" $ txWitRoundTrip (Alonzo Mock), + testProperty "Mary era" $ txWitRoundTrip (Mary Mock), + testProperty "Allegra era" $ txWitRoundTrip (Allegra Mock), + testProperty "Shelley era" $ txWitRoundTrip (Shelley Mock) + ], + testGroup + "TxBody roundtrips" + [ -- testProperty "Babbage era" $ txBodyRoundTrip (Babbage Mock), -- No Arbitrary instance yet + testProperty "Alonzo era" $ txBodyRoundTrip (Alonzo Mock), + testProperty "Mary era" $ txBodyRoundTrip (Mary Mock), + testProperty "Allegra era" $ txBodyRoundTrip (Allegra Mock), + testProperty "Shelley era" $ txBodyRoundTrip (Shelley Mock) + ], + testGroup + "TxOut roundtrips" + [ -- testProperty "Babbage era" $ txOutRoundTrip (Babbage Mock), -- No Arbitrary instance yet + testProperty "Alonzo era" $ txOutRoundTrip (Alonzo Mock), + testProperty "Mary era" $ txOutRoundTrip (Mary Mock), + testProperty "Allegra era" $ txOutRoundTrip (Allegra Mock), + testProperty "Shelley era" $ txOutRoundTrip (Shelley Mock) + ], + testGroup + "Tx roundtrips" + [ -- testProperty "Babbage era" $ txRoundTrip (Babbage Mock), -- No Arbitrary instance yet + testProperty "Alonzo era" $ txRoundTrip (Alonzo Mock), + testProperty "Mary era" $ txRoundTrip (Mary Mock), + testProperty "Allegra era" $ txRoundTrip (Allegra Mock), + testProperty "Shelley era" $ txRoundTrip (Shelley Mock) + ] + ] + +genericProperties :: TestTree +genericProperties = + testGroup + "Generic Property tests" + [ coreTypesRoundTrip, + testGroup + "Alonzo UTXOW property tests" + [ testProperty "Alonzo ValidTx preserves ADA" $ forAll (genTxAndLEDGERState (Alonzo Mock)) (testTxValidForLEDGER (Alonzo Mock)), + testProperty "Mary Tx preserves ADA" $ forAll (genTxAndLEDGERState (Mary Mock)) (testTxValidForLEDGER (Mary Mock)), + testProperty "Shelley Tx preserves ADA" $ forAll (genTxAndLEDGERState (Shelley Mock)) (testTxValidForLEDGER (Shelley Mock)) + ] + ] + +main :: IO () +main = defaultMain genericProperties diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs index 237601ca7c9..7c20bb39f5f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs @@ -35,25 +35,21 @@ import qualified Cardano.Ledger.Babbage.Tx as Babbage (ValidatedTx (..)) import qualified Cardano.Ledger.Babbage.TxBody as Babbage (Datum (..), TxBody (..), TxOut (..)) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Era (..)) -import Cardano.Ledger.Keys -import qualified Cardano.Ledger.Shelley.PParams as PP (PParams, PParams' (..)) +import Cardano.Ledger.Hashes (ScriptHash) +import qualified Cardano.Ledger.Shelley.PParams as Shelley (PParams, PParams' (..)) import Cardano.Ledger.Shelley.Tx as Shelley (WitnessSetHKD (addrWits, bootWits, scriptWits)) import qualified Cardano.Ledger.Shelley.Tx as Shelley (Tx (..)) -import Cardano.Ledger.Shelley.TxBody (Wdrl (..)) import qualified Cardano.Ledger.Shelley.TxBody as Shelley (TxBody (..), TxOut (..)) import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) -import Cardano.Ledger.Val ((<+>)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe.Strict (StrictMaybe (..)) -import Data.Sequence.Strict (StrictSeq) -import qualified Data.Sequence.Strict as Seq (null) import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import Test.Cardano.Ledger.Generic.Fields -import Test.Cardano.Ledger.Generic.Indexed import Test.Cardano.Ledger.Generic.Proof -- =========================================================================== @@ -70,43 +66,36 @@ import Test.Cardano.Ledger.Generic.Proof -- ======================================================================= -- A Policy lets you choose to keep the old (first) or the new (override) --- whenever we have duplicate fields +-- or combine (merge) of two values. We only use this for elements in the +-- WitnessesField data type. That is because we assemble witnesses in small +-- pieces and we combine the pieces together. Every field in WitnessSet and +-- TxWitness has clear way of being merged. We don't use Policies in the other +-- xxxField types because most of those parts cannot be safely combined. +-- (The only execeptions are Coin and Value, but they both have Monoid +-- instances, where we can easliy use (<>) instead.). -type Policy = (forall x. x -> x -> x) +class Merge t where + first :: t -> t -> t + first x _ = x + override :: t -> t -> t + override _ y = y + merge :: t -> t -> t -first :: Policy -first x _y = x +type Policy = (forall t. Merge t => t -> t -> t) -override :: Policy -override _x y = y +-- We need just these 4 instances to merge components of TxWitnesses -class Merge t x | t -> x where - merge :: Policy -> t -> t -> t +instance Ord a => Merge (Set a) where + merge = Set.union -instance Merge (Maybe t) t where - merge _ Nothing x = x - merge _ x Nothing = x - merge p x y = p x y +instance Typeable era => Merge (TxDats era) where + merge (TxDats x) (TxDats y) = TxDats (Map.union x y) -instance Merge (StrictMaybe t) t where - merge _ SNothing x = x - merge _ x SNothing = x - merge p x y = p x y +instance Era era => Merge (Redeemers era) where + merge (Redeemers x) (Redeemers y) = Redeemers (Map.union x y) -instance Merge (Set t) t where - merge _ x y | Set.null x = y - merge _ x y | Set.null y = x - merge p x y = p x y - -instance Merge (Map k t) t where - merge _ x y | Map.null x = y - merge _ x y | Map.null y = x - merge p x y = p x y - -instance Merge (StrictSeq t) t where - merge _ x y | Seq.null x = y - merge _ x y | Seq.null y = x - merge p x y = p x y +instance Merge (Map (ScriptHash c) v) where + merge = Map.union -- ==================================================================== -- Building Era parametric Records @@ -114,160 +103,157 @@ instance Merge (StrictSeq t) t where -- Updaters for Tx -updateTx :: Policy -> Proof era -> Core.Tx era -> TxField era -> Core.Tx era -updateTx p (wit@(Shelley _)) (tx@(Shelley.Tx b w d)) dt = +updateTx :: Proof era -> Core.Tx era -> TxField era -> Core.Tx era +updateTx (wit@(Shelley _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (merge p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses override wit wfields) d + AuxData faux -> Shelley.Tx b w faux Valid _ -> tx -updateTx p (wit@(Allegra _)) (tx@(Shelley.Tx b w d)) dt = +updateTx (wit@(Allegra _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (merge p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses override wit wfields) d + AuxData faux -> Shelley.Tx b w faux Valid _ -> tx -updateTx p (wit@(Mary _)) (tx@(Shelley.Tx b w d)) dt = +updateTx (wit@(Mary _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (merge p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses override wit wfields) d + AuxData faux -> Shelley.Tx b w faux Valid _ -> tx -updateTx p wit@(Alonzo _) (Alonzo.ValidatedTx b w iv d) dt = +updateTx wit@(Alonzo _) (Alonzo.ValidatedTx b w iv d) dt = case dt of Body fbody -> Alonzo.ValidatedTx fbody w iv d - BodyI bfields -> Alonzo.ValidatedTx (newTxBody p wit bfields) w iv d + BodyI bfields -> Alonzo.ValidatedTx (newTxBody wit bfields) w iv d Witnesses fwit -> Alonzo.ValidatedTx b fwit iv d - WitnessesI wfields -> Alonzo.ValidatedTx b (newWitnesses p wit wfields) iv d - AuxData faux -> Alonzo.ValidatedTx b w iv (merge p d faux) - Valid iv' -> Alonzo.ValidatedTx b w (p iv iv') d -updateTx p wit@(Babbage _) (Babbage.ValidatedTx b w iv d) dt = + WitnessesI wfields -> Alonzo.ValidatedTx b (newWitnesses override wit wfields) iv d + AuxData faux -> Alonzo.ValidatedTx b w iv faux + Valid iv' -> Alonzo.ValidatedTx b w iv' d +updateTx wit@(Babbage _) (Babbage.ValidatedTx b w iv d) dt = case dt of Body fbody -> Babbage.ValidatedTx fbody w iv d - BodyI bfields -> Babbage.ValidatedTx (newTxBody p wit bfields) w iv d + BodyI bfields -> Babbage.ValidatedTx (newTxBody wit bfields) w iv d Witnesses fwit -> Babbage.ValidatedTx b fwit iv d - WitnessesI wfields -> Babbage.ValidatedTx b (newWitnesses p wit wfields) iv d - AuxData faux -> Babbage.ValidatedTx b w iv (merge p d faux) - Valid iv' -> Babbage.ValidatedTx b w (p iv iv') d + WitnessesI wfields -> Babbage.ValidatedTx b (newWitnesses override wit wfields) iv d + AuxData faux -> Babbage.ValidatedTx b w iv faux + Valid iv' -> Babbage.ValidatedTx b w iv' d -newTx :: Policy -> Proof era -> [TxField era] -> Core.Tx era -newTx p era = List.foldl' (updateTx p era) (initialTx era) +newTx :: Proof era -> [TxField era] -> Core.Tx era +newTx era = List.foldl' (updateTx era) (initialTx era) -------------------------------------------------------------------- -- Updaters for TxBody -updateTxBody :: Policy -> Proof era -> Core.TxBody era -> TxBodyField era -> Core.TxBody era -updateTxBody p (Shelley _) tx dt = case dt of - (Inputs is) -> tx {Shelley._inputs = p (Shelley._inputs tx) is} - (Collateral is) -> tx {Shelley._inputs = p (Shelley._inputs tx) is} - (Outputs outs) -> tx {Shelley._outputs = p (Shelley._outputs tx) outs} - (Certs cs) -> tx {Shelley._certs = p (Shelley._certs tx) cs} - (Wdrls ws) -> tx {Shelley._wdrls = Wdrl (Map.unionWith (<+>) (unWdrl (Shelley._wdrls tx)) (unWdrl ws))} - (Txfee c) -> tx {Shelley._txfee = (Shelley._txfee tx) <+> c} - (Vldt (ValidityInterval (SJust n) _)) -> tx {Shelley._ttl = n} - (Vldt (ValidityInterval SNothing _)) -> tx {Shelley._ttl = 0} - (Slot n) -> tx {Shelley._ttl = n} - (Update up) -> tx {Shelley._txUpdate = p (Shelley._txUpdate tx) up} - (AdHash hs) -> tx {Shelley._mdHash = merge p (Shelley._mdHash tx) hs} +updateTxBody :: Proof era -> Core.TxBody era -> TxBodyField era -> Core.TxBody era +updateTxBody (Shelley _) tx dt = case dt of + (Inputs is) -> tx {Shelley._inputs = is} + (Outputs outs) -> tx {Shelley._outputs = outs} + (Certs cs) -> tx {Shelley._certs = cs} + (Wdrls ws) -> tx {Shelley._wdrls = ws} + (Txfee c) -> tx {Shelley._txfee = c} + (Vldt (ValidityInterval _ (SJust n))) -> tx {Shelley._ttl = n} + (Vldt (ValidityInterval _ SNothing)) -> tx {Shelley._ttl = 0} + (TTL n) -> tx {Shelley._ttl = n} + (Update up) -> tx {Shelley._txUpdate = up} + (AdHash hs) -> tx {Shelley._mdHash = hs} _ -> tx -updateTxBody p (Allegra _) tx@(MA.TxBody ins outs certs wdrls txfee vldt ups adHash mint) dt = case dt of - (Inputs is) -> MA.TxBody (merge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Collateral is) -> MA.TxBody (merge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Outputs outs1) -> MA.TxBody ins (merge p (MA.outputs' tx) outs1) certs wdrls txfee vldt ups adHash mint - (Certs cs) -> MA.TxBody ins outs (merge p (MA.certs' tx) cs) wdrls txfee vldt ups adHash mint - (Wdrls ws) -> MA.TxBody ins outs certs (Wdrl (Map.unionWith (<+>) (unWdrl (MA.wdrls' tx)) (unWdrl ws))) txfee vldt ups adHash mint - (Txfee c) -> MA.TxBody ins outs certs wdrls ((MA.txfee' tx) <+> c) vldt ups adHash mint +updateTxBody (Allegra _) tx@(MA.TxBody ins outs certs wdrls txfee vldt ups adHash mint) dt = case dt of + (Inputs is) -> MA.TxBody is outs certs wdrls txfee vldt ups adHash mint + (Outputs outs1) -> MA.TxBody ins outs1 certs wdrls txfee vldt ups adHash mint + (Certs cs) -> MA.TxBody ins outs cs wdrls txfee vldt ups adHash mint + (Wdrls ws) -> MA.TxBody ins outs certs ws txfee vldt ups adHash mint + (Txfee c) -> MA.TxBody ins outs certs wdrls c vldt ups adHash mint (Vldt vi) -> MA.TxBody ins outs certs wdrls txfee vi ups adHash mint - (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt (merge p ups up) adHash mint - (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups (merge p adHash hs) mint + (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt up adHash mint + (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups hs mint (Mint v) -> MA.TxBody ins outs certs wdrls txfee vldt ups adHash v _ -> tx -updateTxBody p (Mary _) tx@(MA.TxBody ins outs certs wdrls txfee vldt ups adHash mint) dt = case dt of - (Inputs is) -> MA.TxBody (p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Collateral is) -> MA.TxBody (p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Outputs outs1) -> MA.TxBody ins (p (MA.outputs' tx) outs1) certs wdrls txfee vldt ups adHash mint - (Certs cs) -> MA.TxBody ins outs (p (MA.certs' tx) cs) wdrls txfee vldt ups adHash mint - (Wdrls ws) -> MA.TxBody ins outs certs (Wdrl (Map.unionWith (<+>) (unWdrl (MA.wdrls' tx)) (unWdrl ws))) txfee vldt ups adHash mint - (Txfee c) -> MA.TxBody ins outs certs wdrls ((MA.txfee' tx) <+> c) vldt ups adHash mint +updateTxBody (Mary _) tx@(MA.TxBody ins outs certs wdrls txfee vldt ups adHash mint) dt = case dt of + (Inputs is) -> MA.TxBody is outs certs wdrls txfee vldt ups adHash mint + (Outputs outs1) -> MA.TxBody ins outs1 certs wdrls txfee vldt ups adHash mint + (Certs cs) -> MA.TxBody ins outs cs wdrls txfee vldt ups adHash mint + (Wdrls ws) -> MA.TxBody ins outs certs ws txfee vldt ups adHash mint + (Txfee c) -> MA.TxBody ins outs certs wdrls c vldt ups adHash mint (Vldt vi) -> MA.TxBody ins outs certs wdrls txfee vi ups adHash mint - (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt (merge p ups up) adHash mint - (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups (merge p adHash hs) mint + (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt up adHash mint + (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups hs mint (Mint v) -> MA.TxBody ins outs certs wdrls txfee vldt ups adHash v _ -> tx -updateTxBody p (Alonzo _) tx dt = case dt of - (Inputs is) -> tx {Alonzo.inputs = p (Alonzo.inputs tx) is} - (Collateral is) -> tx {Alonzo.collateral = p (Alonzo.collateral tx) is} - (Outputs outs1) -> tx {Alonzo.outputs = p (Alonzo.outputs tx) outs1} - (Certs cs) -> tx {Alonzo.txcerts = p (Alonzo.txcerts tx) cs} - (Wdrls ws) -> tx {Alonzo.txwdrls = Wdrl (Map.unionWith (<+>) (unWdrl (Alonzo.txwdrls tx)) (unWdrl ws))} - (Txfee c) -> tx {Alonzo.txfee = (Alonzo.txfee tx) <+> c} +updateTxBody (Alonzo _) tx dt = case dt of + (Inputs is) -> tx {Alonzo.inputs = is} + (Collateral is) -> tx {Alonzo.collateral = is} + (Outputs outs1) -> tx {Alonzo.outputs = outs1} + (Certs cs) -> tx {Alonzo.txcerts = cs} + (Wdrls ws) -> tx {Alonzo.txwdrls = ws} + (Txfee c) -> tx {Alonzo.txfee = c} (Vldt vi) -> tx {Alonzo.txvldt = vi} - (Update up) -> tx {Alonzo.txUpdates = merge p (Alonzo.txUpdates tx) up} - (ReqSignerHashes hs) -> tx {Alonzo.reqSignerHashes = p (Alonzo.reqSignerHashes tx) hs} + (Update up) -> tx {Alonzo.txUpdates = up} + (ReqSignerHashes hs) -> tx {Alonzo.reqSignerHashes = hs} (Mint v) -> tx {Alonzo.mint = v} - (WppHash h) -> tx {Alonzo.scriptIntegrityHash = merge p (Alonzo.scriptIntegrityHash tx) h} - (AdHash hs) -> tx {Alonzo.adHash = merge p (Alonzo.adHash tx) hs} + (WppHash h) -> tx {Alonzo.scriptIntegrityHash = h} + (AdHash hs) -> tx {Alonzo.adHash = hs} (Txnetworkid i) -> tx {Alonzo.txnetworkid = i} _ -> tx -updateTxBody p (Babbage _) tx dt = case dt of - (Inputs is) -> tx {Babbage.inputs = p (Babbage.inputs tx) is} - (Collateral is) -> tx {Babbage.collateral = p (Babbage.collateral tx) is} - (RefInputs is) -> tx {Babbage.referenceInputs = p (Babbage.referenceInputs tx) is} - (Outputs outs1) -> tx {Babbage.outputs = p (Babbage.outputs tx) outs1} - (CollateralReturn outs1) -> tx {Babbage.collateralReturn = merge p (Babbage.collateralReturn tx) outs1} - (Certs cs) -> tx {Babbage.txcerts = p (Babbage.txcerts tx) cs} - (Wdrls ws) -> tx {Babbage.txwdrls = Wdrl (Map.unionWith (<+>) (unWdrl (Babbage.txwdrls tx)) (unWdrl ws))} - (Txfee c) -> tx {Babbage.txfee = (Babbage.txfee tx) <+> c} +updateTxBody (Babbage _) tx dt = case dt of + (Inputs is) -> tx {Babbage.inputs = is} + (Collateral is) -> tx {Babbage.collateral = is} + (RefInputs is) -> tx {Babbage.referenceInputs = is} + (Outputs outs1) -> tx {Babbage.outputs = outs1} + (CollateralReturn outs1) -> tx {Babbage.collateralReturn = outs1} + (Certs cs) -> tx {Babbage.txcerts = cs} + (Wdrls ws) -> tx {Babbage.txwdrls = ws} + (Txfee c) -> tx {Babbage.txfee = c} (Vldt vi) -> tx {Babbage.txvldt = vi} - (Update up) -> tx {Babbage.txUpdates = merge p (Babbage.txUpdates tx) up} - (ReqSignerHashes hs) -> tx {Babbage.reqSignerHashes = p (Babbage.reqSignerHashes tx) hs} + (Update up) -> tx {Babbage.txUpdates = up} + (ReqSignerHashes hs) -> tx {Babbage.reqSignerHashes = hs} (Mint v) -> tx {Babbage.mint = v} - (WppHash h) -> tx {Babbage.scriptIntegrityHash = merge p (Babbage.scriptIntegrityHash tx) h} - (AdHash hs) -> tx {Babbage.adHash = merge p (Babbage.adHash tx) hs} + (WppHash h) -> tx {Babbage.scriptIntegrityHash = h} + (AdHash hs) -> tx {Babbage.adHash = hs} (Txnetworkid i) -> tx {Babbage.txnetworkid = i} (TotalCol coin) -> tx {Babbage.totalCollateral = coin} - (Slot _) -> tx + (TTL _) -> tx -newTxBody :: Era era => Policy -> Proof era -> [TxBodyField era] -> Core.TxBody era -newTxBody p era = List.foldl' (updateTxBody p era) (initialTxBody era) +newTxBody :: Era era => Proof era -> [TxBodyField era] -> Core.TxBody era +newTxBody era = List.foldl' (updateTxBody era) (initialTxBody era) -------------------------------------------------------------------- -- Updaters for Witnesses updateWitnesses :: forall era. Policy -> Proof era -> Core.Witnesses era -> WitnessesField era -> Core.Witnesses era updateWitnesses p (Shelley _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = merge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = merge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = merge p (Shelley.scriptWits w) ss} + (AddrWits ks) -> w {Shelley.addrWits = p (Shelley.addrWits w) ks} + (BootWits boots) -> w {Shelley.bootWits = p (Shelley.bootWits w) boots} + (ScriptWits ss) -> w {Shelley.scriptWits = p (Shelley.scriptWits w) ss} _ -> w updateWitnesses p (Allegra _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = merge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = merge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = merge p (Shelley.scriptWits w) ss} + (AddrWits ks) -> w {Shelley.addrWits = p (Shelley.addrWits w) ks} + (BootWits boots) -> w {Shelley.bootWits = p (Shelley.bootWits w) boots} + (ScriptWits ss) -> w {Shelley.scriptWits = p (Shelley.scriptWits w) ss} _ -> w updateWitnesses p (Mary _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = merge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = merge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = merge p (Shelley.scriptWits w) ss} + (AddrWits ks) -> w {Shelley.addrWits = p (Shelley.addrWits w) ks} + (BootWits boots) -> w {Shelley.bootWits = p (Shelley.bootWits w) boots} + (ScriptWits ss) -> w {Shelley.scriptWits = p (Shelley.scriptWits w) ss} _ -> w updateWitnesses p (Alonzo _) w dw = case dw of - (AddrWits ks) -> w {txwitsVKey = merge p (txwitsVKey w) ks} - (BootWits boots) -> w {txwitsBoot = merge p (txwitsBoot w) boots} - (ScriptWits ss) -> w {txscripts = merge p (txscripts w) ss} + (AddrWits ks) -> w {txwitsVKey = p (txwitsVKey w) ks} + (BootWits boots) -> w {txwitsBoot = p (txwitsBoot w) boots} + (ScriptWits ss) -> w {txscripts = p (txscripts w) ss} (DataWits ds) -> w {txdats = p (txdats w) ds} - (RdmrWits r) -> w {txrdmrs = r} -- We do not use a merging sematics on Redeemers because the Hashes would get messed up. + (RdmrWits r) -> w {txrdmrs = p (txrdmrs w) r} updateWitnesses p (Babbage _) w dw = case dw of - (AddrWits ks) -> w {txwitsVKey = merge p (txwitsVKey w) ks} - (BootWits boots) -> w {txwitsBoot = merge p (txwitsBoot w) boots} - (ScriptWits ss) -> w {txscripts = merge p (txscripts w) ss} + (AddrWits ks) -> w {txwitsVKey = p (txwitsVKey w) ks} + (BootWits boots) -> w {txwitsBoot = p (txwitsBoot w) boots} + (ScriptWits ss) -> w {txscripts = p (txscripts w) ss} (DataWits ds) -> w {txdats = p (txdats w) ds} - (RdmrWits r) -> w {txrdmrs = r} -- We do not use a merging sematics on Redeemers because the Hashes would get messed up. + (RdmrWits r) -> w {txrdmrs = p (txrdmrs w) r} newWitnesses :: Era era => Policy -> Proof era -> [WitnessesField era] -> Core.Witnesses era newWitnesses p era = List.foldl' (updateWitnesses p era) (initialWitnesses era) @@ -279,59 +265,60 @@ notAddress :: TxOutField era -> Bool notAddress (Address _) = False notAddress _ = True -updateTxOut :: Policy -> Proof era -> Core.TxOut era -> TxOutField era -> Core.TxOut era -updateTxOut _p (Shelley _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of +updateTxOut :: Proof era -> Core.TxOut era -> TxOutField era -> Core.TxOut era +updateTxOut (Shelley _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (v <+> val) + Amount val -> Shelley.TxOut a val _ -> out -updateTxOut _p (Allegra _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of +updateTxOut (Allegra _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (v <+> val) + Amount val -> Shelley.TxOut a val _ -> out -updateTxOut _p (Mary _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of +updateTxOut (Mary _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (v <+> val) + Amount val -> Shelley.TxOut a val _ -> out -updateTxOut p (Alonzo _) (out@(Alonzo.TxOut a v h)) txoutd = case txoutd of +updateTxOut (Alonzo _) (out@(Alonzo.TxOut a v h)) txoutd = case txoutd of Address addr -> Alonzo.TxOut addr v h - Amount val -> Alonzo.TxOut a (v <+> val) h - DHash mdh -> Alonzo.TxOut a v (merge p h mdh) + Amount val -> Alonzo.TxOut a val h + DHash mdh -> Alonzo.TxOut a v mdh Datum (Babbage.NoDatum) -> Alonzo.TxOut a v h - Datum (Babbage.DatumHash dh) -> Alonzo.TxOut a v (merge p h (SJust dh)) + Datum (Babbage.DatumHash dh) -> Alonzo.TxOut a v (SJust dh) Datum d -> error ("Cannot use a script Datum in the Alonzo era " ++ show d) _ -> out -updateTxOut p (Babbage _) (out@(Babbage.TxOut a v h refscript)) txoutd = case txoutd of +updateTxOut (Babbage _) (out@(Babbage.TxOut a v h refscript)) txoutd = case txoutd of Address addr -> Babbage.TxOut addr v h refscript - Amount val -> Babbage.TxOut a (v <+> val) h refscript - Datum x -> Babbage.TxOut a v (p h x) refscript - RefScript s -> Babbage.TxOut a v h (merge p refscript s) + Amount val -> Babbage.TxOut a val h refscript + Datum x -> Babbage.TxOut a v x refscript + RefScript s -> Babbage.TxOut a v h s _ -> out -newTxOut :: Era era => Policy -> Proof era -> [TxOutField era] -> Core.TxOut era -newTxOut _ _ dts | all notAddress dts = error ("A call to newTxOut must have an (Address x) field.") -newTxOut p era dts = List.foldl' (updateTxOut p era) (initialTxOut era) dts +newTxOut :: Era era => Proof era -> [TxOutField era] -> Core.TxOut era +newTxOut _ dts | all notAddress dts = error ("A call to newTxOut must have an (Address x) field.") +-- This is because we don't have a good story about an initial Address, so the user MUST supply one +newTxOut era dts = List.foldl' (updateTxOut era) (initialTxOut era) dts -- ===================================================== -- | An updater specialized to the Shelley PParams (also used in Allegra and Mary) -updateShelleyPP :: PP.PParams era -> PParamsField era -> PP.PParams era +updateShelleyPP :: Shelley.PParams era -> PParamsField era -> Shelley.PParams era updateShelleyPP pp dpp = case dpp of - (MinfeeA nat) -> pp {PP._minfeeA = nat} - (MinfeeB nat) -> pp {PP._minfeeB = nat} - (MaxBBSize nat) -> pp {PP._maxBBSize = nat} - (MaxTxSize nat) -> pp {PP._maxTxSize = nat} - (MaxBHSize nat) -> pp {PP._maxBHSize = nat} - (KeyDeposit coin) -> pp {PP._keyDeposit = coin} - (PoolDeposit coin) -> pp {PP._poolDeposit = coin} - (EMax e) -> pp {PP._eMax = e} - (NOpt nat) -> pp {PP._nOpt = nat} - (A0 rat) -> pp {PP._a0 = rat} - (Rho u) -> pp {PP._rho = u} - (Tau u) -> pp {PP._tau = u} - (D u) -> pp {PP._d = u} - (ExtraEntropy nonce) -> pp {PP._extraEntropy = nonce} - (ProtocolVersion pv) -> pp {PP._protocolVersion = pv} - (MinPoolCost coin) -> pp {PP._minPoolCost = coin} + (MinfeeA nat) -> pp {Shelley._minfeeA = nat} + (MinfeeB nat) -> pp {Shelley._minfeeB = nat} + (MaxBBSize nat) -> pp {Shelley._maxBBSize = nat} + (MaxTxSize nat) -> pp {Shelley._maxTxSize = nat} + (MaxBHSize nat) -> pp {Shelley._maxBHSize = nat} + (KeyDeposit coin) -> pp {Shelley._keyDeposit = coin} + (PoolDeposit coin) -> pp {Shelley._poolDeposit = coin} + (EMax e) -> pp {Shelley._eMax = e} + (NOpt nat) -> pp {Shelley._nOpt = nat} + (A0 rat) -> pp {Shelley._a0 = rat} + (Rho u) -> pp {Shelley._rho = u} + (Tau u) -> pp {Shelley._tau = u} + (D u) -> pp {Shelley._d = u} + (ExtraEntropy nonce) -> pp {Shelley._extraEntropy = nonce} + (ProtocolVersion pv) -> pp {Shelley._protocolVersion = pv} + (MinPoolCost coin) -> pp {Shelley._minPoolCost = coin} _ -> pp -- | updatePParams uses the Override policy exclusively @@ -356,7 +343,8 @@ updatePParams (Alonzo _) pp dpp = case dpp of (ExtraEntropy nonce) -> pp {Alonzo._extraEntropy = nonce} (ProtocolVersion pv) -> pp {Alonzo._protocolVersion = pv} (MinPoolCost coin) -> pp {Alonzo._minPoolCost = coin} - Costmdls cost -> pp {Alonzo._costmdls = cost} + (Costmdls cost) -> pp {Alonzo._costmdls = cost} + (Prices n) -> pp {Alonzo._prices = n} MaxValSize n -> pp {Alonzo._maxValSize = n} MaxTxExUnits n -> pp {Alonzo._maxTxExUnits = n} MaxBlockExUnits n -> pp {Alonzo._maxBlockExUnits = n} @@ -378,11 +366,15 @@ updatePParams (Babbage _) pp dpp = case dpp of (ProtocolVersion pv) -> pp {Babbage._protocolVersion = pv} (MinPoolCost coin) -> pp {Babbage._minPoolCost = coin} Costmdls cost -> pp {Babbage._costmdls = cost} + Prices n -> pp {Babbage._prices = n} MaxValSize n -> pp {Babbage._maxValSize = n} MaxTxExUnits n -> pp {Babbage._maxTxExUnits = n} MaxBlockExUnits n -> pp {Babbage._maxBlockExUnits = n} CollateralPercentage perc -> pp {Babbage._collateralPercentage = perc} - _ -> pp + MaxCollateralInputs n -> pp {Babbage._maxCollateralInputs = n} + D _ -> pp -- All these are no longer in Babbage + ExtraEntropy _ -> pp + AdaPerUTxOWord _ -> pp newPParams :: Proof era -> [PParamsField era] -> Core.PParams era newPParams era = List.foldl' (updatePParams era) (initialPParams era) @@ -402,6 +394,3 @@ newScriptIntegrityHash (Alonzo _) pp ls rds dats = SJust x -> SJust x SNothing -> SNothing newScriptIntegrityHash _wit _pp _ls _rds _dats = SNothing - -vkey :: Era era => Int -> Proof era -> VKey 'Witness (Crypto era) -vkey n _w = theVKey n diff --git a/libs/cardano-ledger-test/test/Tests.hs b/libs/cardano-ledger-test/test/Tests.hs index ec258e7c1d7..1746a33a0fb 100644 --- a/libs/cardano-ledger-test/test/Tests.hs +++ b/libs/cardano-ledger-test/test/Tests.hs @@ -16,6 +16,7 @@ import Test.Cardano.Ledger.Examples.TwoPhaseValidation alonzoUTXOWexamples, collectOrderingAlonzo, ) +import Test.Cardano.Ledger.Generic.Properties (genericProperties) import Test.Cardano.Ledger.Model.Properties (modelUnitTests_) import Test.Cardano.Ledger.Properties (alonzoProperties) import Test.Tasty @@ -43,7 +44,8 @@ mainTests = collectOrderingAlonzo, alonzoProperties, modelUnitTests_ - ] + ], + genericProperties ] -- main entry point