From 3edb9719ef00df9587a166114002f23bae67b6a9 Mon Sep 17 00:00:00 2001 From: TimSheard Date: Thu, 3 Feb 2022 15:15:50 -0800 Subject: [PATCH] Updated generic builders for Babbage. Added the Parametric class on PParams for use in Tests. --- .../cardano-ledger-test.cabal | 4 + .../src/Test/Cardano/Ledger/Alonzo/Tools.hs | 12 +- .../Ledger/Examples/TwoPhaseValidation.hs | 567 +++++++------- .../src/Test/Cardano/Ledger/Generic/Fields.hs | 616 +++++++++++++++ .../Test/Cardano/Ledger/Generic/Indexed.hs | 14 +- .../Test/Cardano/Ledger/Generic/Parametric.hs | 216 ++++++ .../src/Test/Cardano/Ledger/Generic/Proof.hs | 77 +- .../Test/Cardano/Ledger/Generic/Scriptic.hs | 156 ++++ .../Test/Cardano/Ledger/Generic/Updaters.hs | 706 +++++------------- 9 files changed, 1598 insertions(+), 770 deletions(-) create mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs create mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Parametric.hs create mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Scriptic.hs diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal index 94cfed7b571..3f915687727 100644 --- a/libs/cardano-ledger-test/cardano-ledger-test.cabal +++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal @@ -49,7 +49,10 @@ library Test.Cardano.Ledger.BaseTypes Test.Cardano.Ledger.Examples.TwoPhaseValidation Test.Cardano.Ledger.Generic.Indexed + Test.Cardano.Ledger.Generic.Fields + Test.Cardano.Ledger.Generic.Parametric Test.Cardano.Ledger.Generic.Proof + Test.Cardano.Ledger.Generic.Scriptic Test.Cardano.Ledger.Generic.Updaters Test.Cardano.Ledger.Model.API Test.Cardano.Ledger.Model.Acnt @@ -94,6 +97,7 @@ library cardano-data, cardano-ledger-alonzo, cardano-ledger-alonzo-test, + cardano-ledger-babbage, cardano-ledger-core, cardano-ledger-pretty, cardano-ledger-shelley-ma, 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 caa8c4c15fb..82e4a1b1dbd 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 @@ -35,7 +35,9 @@ import Data.Maybe (fromJust) import Test.Cardano.Ledger.Alonzo.PlutusScripts (defaultCostModel) import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () import Test.Cardano.Ledger.Examples.TwoPhaseValidation (A, datumExample1, initUTxO, someKeys, testSystemStart, validatingBody, validatingRedeemersEx1) +import Test.Cardano.Ledger.Generic.Fields (PParamsField (..), TxField (..), WitnessesField (..)) import Test.Cardano.Ledger.Generic.Proof (Evidence (Mock), Proof (Alonzo)) +import Test.Cardano.Ledger.Generic.Scriptic (always) import Test.Cardano.Ledger.Generic.Updaters import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase) import Test.Tasty (TestTree, testGroup) @@ -116,13 +118,13 @@ exampleTx :: Core.Tx A exampleTx = let pf = Alonzo Mock in newTx - Override + override pf [ Body (validatingBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] 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 846e54bbc98..c404fa78d55 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 @@ -38,9 +38,11 @@ import Cardano.Ledger.Alonzo.Tx hashScriptIntegrity, minfee, ) -import Cardano.Ledger.Alonzo.TxInfo (FailureDescription (..), txInfo, valContext) +-- PParam HasField instances +import Cardano.Ledger.Alonzo.TxInfo (FailureDescription (..), TranslationError, VersionedTxInfo, txInfo, valContext) import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr (..), Redeemers (..), TxDats (..), unRedeemers) import Cardano.Ledger.BHeaderView (BHeaderView (..)) +import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams' (..)) import Cardano.Ledger.BaseTypes ( BlocksMade (..), Network (..), @@ -130,8 +132,16 @@ import GHC.Stack import Numeric.Natural (Natural) import Plutus.V1.Ledger.Api (defaultCostModelParams) import qualified Plutus.V1.Ledger.Api as Plutus +import Test.Cardano.Ledger.Generic.Fields + ( PParamsField (..), + TxBodyField (..), + TxField (..), + TxOutField (..), + WitnessesField (..), + ) import Test.Cardano.Ledger.Generic.Indexed (theKeyPair) import Test.Cardano.Ledger.Generic.Proof +import Test.Cardano.Ledger.Generic.Scriptic (HasTokens (..), PostShelley, Scriptic (..), after, matchkey) import Test.Cardano.Ledger.Generic.Updaters import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto, TestCrypto) import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId) @@ -203,16 +213,16 @@ 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 override pf [Address $ someAddr pf, Amount (inject $ Coin 1000)] nonScriptOutWithDatum :: forall era. (Scriptic era) => Proof era -> Core.TxOut era nonScriptOutWithDatum pf = newTxOut - Override + override pf [ Address (someAddr pf), Amount (inject $ Coin 1221), - DHash [hashData $ datumExample1 @era] + DHash' [hashData $ datumExample1 @era] ] mkGenesisTxIn :: (CH.HashAlgorithm (CC.HASH crypto), HasCallStack) => Integer -> TxIn crypto @@ -220,7 +230,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 override pf [Address $ someAddr pf, Amount (inject $ Coin 5)] alwaysSucceedsHash :: forall era. @@ -253,14 +263,14 @@ 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 override 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 + override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 5000) @@ -340,21 +350,21 @@ txDatsExample1 = TxDats $ keyBy hashData $ [datumExample1] alwaysSucceedsOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysSucceedsOutput pf = newTxOut - Override + override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 5000), - DHash [hashData $ datumExample1 @era] + DHash' [hashData $ datumExample1 @era] ] alwaysSucceedsOutputV2 :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysSucceedsOutputV2 pf = newTxOut - Override + override pf [ Address (scriptAddr (alwaysAlt 3 pf) pf), Amount (inject $ Coin 5000), - DHash [hashData $ datumExample1 @era] + DHash' [hashData $ datumExample1 @era] ] validatingRedeemersEx1 :: Era era => Redeemers era @@ -370,11 +380,11 @@ extraRedeemersEx = extraRedeemersBody :: Scriptic era => Proof era -> Core.TxBody era extraRedeemersBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] extraRedeemersEx txDatsExample1) ] @@ -388,28 +398,28 @@ extraRedeemersTx :: Core.Tx era extraRedeemersTx pf = newTx - Override + override pf [ Body (extraRedeemersBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (extraRedeemersBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (extraRedeemersBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits extraRedeemersEx ] ] outEx1 :: Scriptic era => Proof era -> Core.TxOut era -outEx1 pf = newTxOut Override pf [Address (someAddr pf), Amount (inject $ Coin 4995)] +outEx1 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 4995)] validatingBody :: Scriptic era => Proof era -> Core.TxBody era validatingBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersEx1 txDatsExample1) ] @@ -429,13 +439,13 @@ validatingTx :: Core.Tx era validatingTx pf = newTx - Override + override pf [ Body (validatingBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] @@ -476,24 +486,24 @@ notValidatingRedeemers = alwaysFailsOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era alwaysFailsOutput pf = newTxOut - Override + override pf [ Address (scriptAddr (never 0 pf) pf), Amount (inject $ Coin 3000), - DHash [hashData $ datumExample2 @era] + DHash' [hashData $ datumExample2 @era] ] outEx2 :: (Scriptic era) => Proof era -> Core.TxOut era -outEx2 pf = newTxOut Override pf [Address (someAddr pf), Amount (inject $ Coin 2995)] +outEx2 pf = newTxOut override pf [Address (someAddr pf), Amount (inject $ Coin 2995)] notValidatingBody :: Scriptic era => Proof era -> Core.TxBody era notValidatingBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 2], - Collateral [mkGenesisTxIn 12], - Outputs [outEx2 pf], + [ Inputs' [mkGenesisTxIn 2], + Collateral' [mkGenesisTxIn 12], + Outputs' [outEx2 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] notValidatingRedeemers txDatsExample2) ] @@ -506,13 +516,13 @@ notValidatingTx :: Core.Tx era notValidatingTx pf = newTx - Override + override pf [ Body (notValidatingBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (notValidatingBody pf)) (someKeys pf)], - ScriptWits [never 0 pf], - DataWits [datumExample2], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (notValidatingBody pf)) (someKeys pf)], + ScriptWits' [never 0 pf], + DataWits' [datumExample2], RdmrWits notValidatingRedeemers ] ] @@ -531,7 +541,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 override pf [Address (someAddr pf), Amount (inject $ Coin 995)] redeemerExample3 :: Data era redeemerExample3 = Data (Plutus.I 42) @@ -547,12 +557,12 @@ scriptStakeCredSuceed pf = ScriptHashObj (alwaysSucceedsHash 2 pf) validatingBodyWithCert :: Scriptic era => Proof era -> Core.TxBody era validatingBodyWithCert pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Collateral [mkGenesisTxIn 13], - Outputs [outEx3 pf], - Certs [DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf)], + [ Inputs' [mkGenesisTxIn 3], + Collateral' [mkGenesisTxIn 13], + Outputs' [outEx3 pf], + Certs' [DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf)], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersEx3 mempty) ] @@ -566,12 +576,12 @@ validatingTxWithCert :: Core.Tx era validatingTxWithCert pf = newTx - Override + override pf [ Body (validatingBodyWithCert pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBodyWithCert pf)) (someKeys pf)], - ScriptWits [always 2 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (validatingBodyWithCert pf)) (someKeys pf)], + ScriptWits' [always 2 pf], RdmrWits validatingRedeemersEx3 ] ] @@ -590,7 +600,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 override pf [Address (someAddr pf), Amount (inject $ Coin 995)] redeemerExample4 :: Data era redeemerExample4 = Data (Plutus.I 0) @@ -606,12 +616,12 @@ scriptStakeCredFail pf = ScriptHashObj (alwaysFailsHash 1 pf) notValidatingBodyWithCert :: Scriptic era => Proof era -> Core.TxBody era notValidatingBodyWithCert pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 4], - Collateral [mkGenesisTxIn 14], - Outputs [outEx4 pf], - Certs [DCertDeleg (DeRegKey $ scriptStakeCredFail pf)], + [ Inputs' [mkGenesisTxIn 4], + Collateral' [mkGenesisTxIn 14], + Outputs' [outEx4 pf], + Certs' [DCertDeleg (DeRegKey $ scriptStakeCredFail pf)], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] notValidatingRedeemersEx4 mempty) ] @@ -625,12 +635,12 @@ notValidatingTxWithCert :: Core.Tx era notValidatingTxWithCert pf = newTx - Override + override pf [ Body (notValidatingBodyWithCert pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (notValidatingBodyWithCert pf)) (someKeys pf)], - ScriptWits [never 1 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (notValidatingBodyWithCert pf)) (someKeys pf)], + ScriptWits' [never 1 pf], RdmrWits notValidatingRedeemersEx4 ] ] @@ -649,7 +659,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 override pf [Address (someAddr pf), Amount (inject $ Coin 1995)] redeemerExample5 :: Data era redeemerExample5 = Data (Plutus.I 42) @@ -662,11 +672,11 @@ validatingRedeemersEx5 = validatingBodyWithWithdrawal :: Scriptic era => Proof era -> Core.TxBody era validatingBodyWithWithdrawal pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 5], - Collateral [mkGenesisTxIn 15], - Outputs [outEx5 pf], + [ Inputs' [mkGenesisTxIn 5], + Collateral' [mkGenesisTxIn 15], + Outputs' [outEx5 pf], Txfee (Coin 5), Wdrls ( Wdrl $ @@ -686,12 +696,12 @@ validatingTxWithWithdrawal :: Core.Tx era validatingTxWithWithdrawal pf = newTx - Override + override pf [ Body (validatingBodyWithWithdrawal pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBodyWithWithdrawal pf)) (someKeys pf)], - ScriptWits [always 2 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (validatingBodyWithWithdrawal pf)) (someKeys pf)], + ScriptWits' [always 2 pf], RdmrWits validatingRedeemersEx5 ] ] @@ -710,7 +720,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 override pf [Address (someAddr pf), Amount (inject $ Coin 1995)] redeemerExample6 :: Data era redeemerExample6 = Data (Plutus.I 0) @@ -723,11 +733,11 @@ notValidatingRedeemersEx6 = notValidatingBodyWithWithdrawal :: Scriptic era => Proof era -> Core.TxBody era notValidatingBodyWithWithdrawal pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 6], - Collateral [mkGenesisTxIn 16], - Outputs [outEx6 pf], + [ Inputs' [mkGenesisTxIn 6], + Collateral' [mkGenesisTxIn 16], + Outputs' [outEx6 pf], Txfee (Coin 5), Wdrls ( Wdrl $ @@ -747,12 +757,12 @@ notValidatingTxWithWithdrawal :: Core.Tx era notValidatingTxWithWithdrawal pf = newTx - Override + override pf [ Body (notValidatingBodyWithWithdrawal pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (notValidatingBodyWithWithdrawal pf)) (someKeys pf)], - ScriptWits [never 1 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (notValidatingBodyWithWithdrawal pf)) (someKeys pf)], + ScriptWits' [never 1 pf], RdmrWits notValidatingRedeemersEx6 ] ] @@ -774,7 +784,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 override pf [Address (someAddr pf), Amount (mintEx7 pf <+> inject (Coin 995))] redeemerExample7 :: Data era redeemerExample7 = Data (Plutus.I 42) @@ -787,11 +797,11 @@ validatingRedeemersEx7 = validatingBodyWithMint :: (HasTokens era, Scriptic era) => Proof era -> Core.TxBody era validatingBodyWithMint pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 7], - Collateral [mkGenesisTxIn 17], - Outputs [outEx7 pf], + [ Inputs' [mkGenesisTxIn 7], + Collateral' [mkGenesisTxIn 17], + Outputs' [outEx7 pf], Txfee (Coin 5), Mint (mintEx7 pf), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersEx7 mempty) @@ -807,12 +817,12 @@ validatingTxWithMint :: Core.Tx era validatingTxWithMint pf = newTx - Override + override pf [ Body (validatingBodyWithMint pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBodyWithMint pf)) (someKeys pf)], - ScriptWits [always 2 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (validatingBodyWithMint pf)) (someKeys pf)], + ScriptWits' [always 2 pf], RdmrWits validatingRedeemersEx7 ] ] @@ -835,7 +845,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 override pf [Address (someAddr pf), Amount (mintEx8 pf <+> inject (Coin 995))] redeemerExample8 :: Data era redeemerExample8 = Data (Plutus.I 0) @@ -848,11 +858,11 @@ notValidatingRedeemersEx8 = notValidatingBodyWithMint :: (HasTokens era, Scriptic era) => Proof era -> Core.TxBody era notValidatingBodyWithMint pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 8], - Collateral [mkGenesisTxIn 18], - Outputs [outEx8 pf], + [ Inputs' [mkGenesisTxIn 8], + Collateral' [mkGenesisTxIn 18], + Outputs' [outEx8 pf], Txfee (Coin 5), Mint (mintEx8 pf), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] notValidatingRedeemersEx8 mempty) @@ -868,12 +878,12 @@ notValidatingTxWithMint :: Core.Tx era notValidatingTxWithMint pf = newTx - Override + override pf [ Body (notValidatingBodyWithMint pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (notValidatingBodyWithMint pf)) (someKeys pf)], - ScriptWits [never 1 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (notValidatingBodyWithMint pf)) (someKeys pf)], + ScriptWits' [never 1 pf], RdmrWits notValidatingRedeemersEx8 ] ] @@ -907,7 +917,7 @@ 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 + override pf [ Address (someAddr pf), Amount (mintEx9 pf <+> inject (Coin 4996)) @@ -922,13 +932,13 @@ validatingBodyManyScripts :: Core.TxBody era validatingBodyManyScripts pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1, mkGenesisTxIn 100], - Collateral [mkGenesisTxIn 11], - Outputs [outEx9 pf], + [ Inputs' [mkGenesisTxIn 1, mkGenesisTxIn 100], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx9 pf], Txfee (Coin 5), - Certs + Certs' [ DCertDeleg (DeRegKey $ timelockStakeCred pf), DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf) ], @@ -954,22 +964,22 @@ validatingTxManyScripts :: Core.Tx era validatingTxManyScripts pf = newTx - Override + override pf [ Body (validatingBodyManyScripts pf), - Witnesses' - [ AddrWits $ + WitnessesI + [ AddrWits' $ map (makeWitnessVKey . hashAnnotated . validatingBodyManyScripts $ pf) [someKeys pf, theKeyPair 1], - ScriptWits + ScriptWits' [ always 2 pf, always 3 pf, timelockScript 0 pf, timelockScript 1 pf, timelockScript 2 pf ], - DataWits [datumExample1], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx9 ] ] @@ -997,20 +1007,20 @@ utxoStEx9 pf = smartUTxOState (utxoEx9 pf) (Coin 0) (Coin 5) def outEx10 :: forall era. (Scriptic era) => Proof era -> Core.TxOut era outEx10 pf = newTxOut - Override + override pf [ Address (scriptAddr (always 3 pf) pf), Amount (inject $ Coin 995), - DHash [hashData $ datumExample1 @era] + DHash' [hashData $ datumExample1 @era] ] okSupplimentaryDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era okSupplimentaryDatumTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Outputs [outEx10 pf], + [ Inputs' [mkGenesisTxIn 3], + Outputs' [outEx10 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [] (Redeemers mempty) txDatsExample1) ] @@ -1024,12 +1034,12 @@ okSupplimentaryDatumTx :: Core.Tx era okSupplimentaryDatumTx pf = newTx - Override + override pf [ Body (okSupplimentaryDatumTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (okSupplimentaryDatumTxBody pf)) (someKeys pf)], - DataWits [datumExample1] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (okSupplimentaryDatumTxBody pf)) (someKeys pf)], + DataWits' [datumExample1] ] ] @@ -1057,12 +1067,12 @@ multipleEqualCertsRedeemers = multipleEqualCertsBody :: Scriptic era => Proof era -> Core.TxBody era multipleEqualCertsBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Collateral [mkGenesisTxIn 13], - Outputs [outEx3 pf], - Certs + [ Inputs' [mkGenesisTxIn 3], + Collateral' [mkGenesisTxIn 13], + Outputs' [outEx3 pf], + Certs' [ DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf), DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf) -- not allowed by DELEG, but here is fine ], @@ -1079,12 +1089,12 @@ multipleEqualCertsTx :: Core.Tx era multipleEqualCertsTx pf = newTx - Override + override pf [ Body (multipleEqualCertsBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (multipleEqualCertsBody pf)) (someKeys pf)], - ScriptWits [always 2 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (multipleEqualCertsBody pf)) (someKeys pf)], + ScriptWits' [always 2 pf], RdmrWits multipleEqualCertsRedeemers ] ] @@ -1107,15 +1117,15 @@ 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 override pf [Address (someAddr pf), Amount (inject $ Coin 1216)] nonScriptOutWithDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era nonScriptOutWithDatumTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 103], - Outputs [outEx12 pf], + [ Inputs' [mkGenesisTxIn 103], + Outputs' [outEx12 pf], Txfee (Coin 5) ] @@ -1128,11 +1138,11 @@ nonScriptOutWithDatumTx :: Core.Tx era nonScriptOutWithDatumTx pf = newTx - Override + override pf [ Body (nonScriptOutWithDatumTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (nonScriptOutWithDatumTxBody pf)) (someKeys pf)] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (nonScriptOutWithDatumTxBody pf)) (someKeys pf)] ] ] @@ -1159,10 +1169,10 @@ utxoStEx12 pf = incorrectNetworkIDTxBody :: Era era => Proof era -> Core.TxBody era incorrectNetworkIDTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Outputs [outEx3 pf], + [ Inputs' [mkGenesisTxIn 3], + Outputs' [outEx3 pf], Txfee (Coin 5), Txnetworkid (SJust Mainnet) ] @@ -1170,11 +1180,11 @@ incorrectNetworkIDTxBody pf = incorrectNetworkIDTx :: (Era era, SignBody era) => Proof era -> Core.Tx era incorrectNetworkIDTx pf = newTx - Override + override pf [ Body (incorrectNetworkIDTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (incorrectNetworkIDTxBody pf)) (someKeys pf)] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (incorrectNetworkIDTxBody pf)) (someKeys pf)] ] ] @@ -1184,33 +1194,33 @@ extraneousKeyHash = hashKey . snd . mkKeyPair $ RawSeed 0 0 0 0 99 missingRequiredWitnessTxBody :: Era era => Proof era -> Core.TxBody era missingRequiredWitnessTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Outputs [outEx3 pf], + [ Inputs' [mkGenesisTxIn 3], + Outputs' [outEx3 pf], Txfee (Coin 5), - ReqSignerHashes [extraneousKeyHash] + ReqSignerHashes' [extraneousKeyHash] ] missingRequiredWitnessTx :: (Era era, SignBody era) => Proof era -> Core.Tx era missingRequiredWitnessTx pf = newTx - Override + override pf [ Body (missingRequiredWitnessTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (missingRequiredWitnessTxBody pf)) (someKeys pf)] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (missingRequiredWitnessTxBody pf)) (someKeys pf)] ] ] missingRedeemerTxBody :: Scriptic era => Proof era -> Core.TxBody era missingRedeemerTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] (Redeemers mempty) txDatsExample1) ] @@ -1221,13 +1231,13 @@ missingRedeemerTx :: Core.Tx era missingRedeemerTx pf = newTx - Override + override pf [ Body (missingRedeemerTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (missingRedeemerTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (missingRedeemerTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1] ] ] @@ -1237,13 +1247,13 @@ wrongWppHashTx :: Core.Tx era wrongWppHashTx pf = newTx - Override + override pf [ Body (missingRedeemerTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (missingRedeemerTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (missingRedeemerTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] @@ -1258,22 +1268,22 @@ missing1phaseScriptWitnessTx :: Core.Tx era missing1phaseScriptWitnessTx pf = newTx - Override + override pf [ Body (validatingBodyManyScripts pf), - Witnesses' - [ AddrWits $ + WitnessesI + [ AddrWits' $ map (makeWitnessVKey . hashAnnotated . validatingBodyManyScripts $ pf) [someKeys pf, theKeyPair 1], - ScriptWits + ScriptWits' [ always 2 pf, always 3 pf, -- intentionally missing -> timelockScript 0 pf, timelockScript 1 pf, timelockScript 2 pf ], - DataWits [datumExample1], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx9 ] ] @@ -1288,22 +1298,22 @@ missing2phaseScriptWitnessTx :: Core.Tx era missing2phaseScriptWitnessTx pf = newTx - Override + override pf [ Body (validatingBodyManyScripts pf), - Witnesses' - [ AddrWits $ + WitnessesI + [ AddrWits' $ map (makeWitnessVKey . hashAnnotated . validatingBodyManyScripts $ pf) [someKeys pf, theKeyPair 1], - ScriptWits + ScriptWits' [ -- intentionally missing -> always 2 pf, always 3 pf, timelockScript 0 pf, timelockScript 1 pf, timelockScript 2 pf ], - DataWits [datumExample1], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx9 ] ] @@ -1317,11 +1327,11 @@ misPurposedRedeemer = wrongRedeemerLabelTxBody :: Scriptic era => Proof era -> Core.TxBody era wrongRedeemerLabelTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] misPurposedRedeemer txDatsExample1) ] @@ -1335,13 +1345,13 @@ wrongRedeemerLabelTx :: Core.Tx era wrongRedeemerLabelTx pf = newTx - Override + override pf [ Body (wrongRedeemerLabelTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (wrongRedeemerLabelTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (wrongRedeemerLabelTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits misPurposedRedeemer ] ] @@ -1349,11 +1359,11 @@ wrongRedeemerLabelTx pf = missingDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era missingDatumTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersEx1 mempty) ] @@ -1367,12 +1377,12 @@ missingDatumTx :: Core.Tx era missingDatumTx pf = newTx - Override + override pf [ Body (missingDatumTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (missingDatumTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (missingDatumTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], RdmrWits validatingRedeemersEx1 ] ] @@ -1387,23 +1397,23 @@ phase1FailureTx :: Core.Tx era phase1FailureTx pf = newTx - Override + override pf [ Body (validatingBodyManyScripts pf), - Witnesses' - [ AddrWits + WitnessesI + [ AddrWits' [ makeWitnessVKey (hashAnnotated $ validatingBodyManyScripts pf) (someKeys pf) ], - ScriptWits + ScriptWits' [ always 2 pf, always 3 pf, timelockScript 0 pf, timelockScript 1 pf, timelockScript 2 pf ], - DataWits [datumExample1], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx9 ] ] @@ -1416,11 +1426,11 @@ validatingRedeemersTooManyExUnits = tooManyExUnitsTxBody :: Scriptic era => Proof era -> Core.TxBody era tooManyExUnitsTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 1], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 1], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersTooManyExUnits txDatsExample1) ] @@ -1434,13 +1444,13 @@ tooManyExUnitsTx :: Core.Tx era tooManyExUnitsTx pf = newTx - Override + override pf [ Body (tooManyExUnitsTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (tooManyExUnitsTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (tooManyExUnitsTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersTooManyExUnits ] ] @@ -1452,12 +1462,12 @@ missingCollateralSig :: Core.Tx era missingCollateralSig pf = newTx - Override + override pf [ Body (validatingBody pf), - Witnesses' - [ ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] @@ -1465,11 +1475,11 @@ missingCollateralSig pf = plutusOutputWithNoDataTxBody :: Scriptic era => Proof era -> Core.TxBody era plutusOutputWithNoDataTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 101], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 101], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV1] validatingRedeemersEx1 mempty) ] @@ -1483,12 +1493,12 @@ plutusOutputWithNoDataTx :: Core.Tx era plutusOutputWithNoDataTx pf = newTx - Override + override pf [ Body (plutusOutputWithNoDataTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (plutusOutputWithNoDataTxBody pf)) (someKeys pf)], - ScriptWits [always 3 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (plutusOutputWithNoDataTxBody pf)) (someKeys pf)], + ScriptWits' [always 3 pf], RdmrWits validatingRedeemersEx1 ] ] @@ -1497,15 +1507,15 @@ 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 override pf [Address $ someAddr pf, Amount (inject $ Coin 995)] notOkSupplimentaryDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era notOkSupplimentaryDatumTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Outputs [outputWithNoDatum pf], + [ Inputs' [mkGenesisTxIn 3], + Outputs' [outputWithNoDatum pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [] (Redeemers mempty) totallyIrrelevantTxDats) ] @@ -1521,12 +1531,12 @@ notOkSupplimentaryDatumTx :: Core.Tx era notOkSupplimentaryDatumTx pf = newTx - Override + override pf [ Body (notOkSupplimentaryDatumTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (notOkSupplimentaryDatumTxBody pf)) (someKeys pf)], - DataWits [totallyIrrelevantDatum] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (notOkSupplimentaryDatumTxBody pf)) (someKeys pf)], + DataWits' [totallyIrrelevantDatum] ] ] @@ -1536,11 +1546,11 @@ hashsize = fromIntegral $ sizeHash ([] @(CC.HASH c)) poolMDHTooBigTxBody :: forall era. Scriptic era => Proof era -> Core.TxBody era poolMDHTooBigTxBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Outputs [newTxOut Override pf [Address $ someAddr pf, Amount (inject $ Coin 995)]], - Certs [DCertPool (RegPool poolParams)], + [ Inputs' [mkGenesisTxIn 3], + Outputs' [newTxOut override pf [Address $ someAddr pf, Amount (inject $ Coin 995)]], + Certs' [DCertPool (RegPool poolParams)], Txfee (Coin 5) ] where @@ -1569,11 +1579,11 @@ 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 + override pf [ Body (poolMDHTooBigTxBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (poolMDHTooBigTxBody pf)) (someKeys pf)] + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (poolMDHTooBigTxBody pf)) (someKeys pf)] ] ] @@ -1588,12 +1598,12 @@ multipleEqualCertsRedeemersInvalid = multipleEqualCertsBodyInvalid :: Scriptic era => Proof era -> Core.TxBody era multipleEqualCertsBodyInvalid pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 3], - Collateral [mkGenesisTxIn 13], - Outputs [outEx3 pf], - Certs + [ Inputs' [mkGenesisTxIn 3], + Collateral' [mkGenesisTxIn 13], + Outputs' [outEx3 pf], + Certs' [ DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf), DCertDeleg (DeRegKey $ scriptStakeCredSuceed pf) -- not allowed by DELEG, but here is fine ], @@ -1610,12 +1620,12 @@ multipleEqualCertsTxInvalid :: Core.Tx era multipleEqualCertsTxInvalid pf = newTx - Override + override pf [ Body (multipleEqualCertsBodyInvalid pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (multipleEqualCertsBodyInvalid pf)) (someKeys pf)], - ScriptWits [always 2 pf], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (multipleEqualCertsBodyInvalid pf)) (someKeys pf)], + ScriptWits' [always 2 pf], RdmrWits multipleEqualCertsRedeemersInvalid ] ] @@ -1623,11 +1633,11 @@ multipleEqualCertsTxInvalid pf = noCostModelBody :: Scriptic era => Proof era -> Core.TxBody era noCostModelBody pf = newTxBody - Override + override pf - [ Inputs [mkGenesisTxIn 102], - Collateral [mkGenesisTxIn 11], - Outputs [outEx1 pf], + [ Inputs' [mkGenesisTxIn 102], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], Txfee (Coin 5), WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV2] validatingRedeemersEx1 txDatsExample1) ] @@ -1641,13 +1651,13 @@ noCostModelTx :: Core.Tx era noCostModelTx pf = newTx - Override + override pf [ Body (noCostModelBody pf), - Witnesses' - [ AddrWits [makeWitnessVKey (hashAnnotated (noCostModelBody pf)) (someKeys pf)], - ScriptWits [alwaysAlt 3 pf], - DataWits [datumExample1], + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (noCostModelBody pf)) (someKeys pf)], + ScriptWits' [alwaysAlt 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] @@ -2026,11 +2036,52 @@ alonzoUTXOWexamples = where pf = Alonzo Mock --- Test for Plutus Data Ordering +-- ========================= +-- We have some tests that use plutus scripts, so they can only be run in +-- Babbage and Alonzo. How do we do that? We identify functions that are +-- only well typed in those Eras, and we make versions which are parameterized +-- by a proof. But which raise an error in other Eras. -collectTwoPhaseScriptInputsOutputOrdering :: Assertion -collectTwoPhaseScriptInputsOutputOrdering = - collectTwoPhaseScriptInputs testEpochInfo testSystemStart (pp apf) (validatingTx apf) (initUTxO apf) +collectInputs :: + forall era. + Proof era -> + EpochInfo Identity -> + SystemStart -> + Core.PParams era -> + Core.Tx era -> + UTxO era -> + Either + [CollectError (Crypto era)] + [(Core.Script era, [Data era], ExUnits, CostModel)] +collectInputs (Alonzo _) = collectTwoPhaseScriptInputs @era +collectInputs (Babbage _) = collectTwoPhaseScriptInputs @era +collectInputs x = error ("collectInputs Not defined in era " ++ show x) + +getTxInfo :: + Monad m => + Proof era -> + Core.PParams era -> + Language -> + EpochInfo m -> + SystemStart -> + UTxO era -> + Core.Tx era -> + m (Either TranslationError VersionedTxInfo) +getTxInfo (Alonzo _) = txInfo +getTxInfo (Babbage _) = txInfo +getTxInfo era = error ("getTxInfo Not defined in era " ++ show era) + +-- Test for Plutus Data Ordering, using this strategy + +-- | Never apply this to any Era but Alonzo or Babbage +collectTwoPhaseScriptInputsOutputOrdering :: + ( Reflect era, + PostShelley era -- Generate Scripts with Timelocking + ) => + Proof era -> + Assertion +collectTwoPhaseScriptInputsOutputOrdering apf = + collectInputs apf testEpochInfo testSystemStart (pp apf) (validatingTx apf) (initUTxO apf) @?= Right [ ( always 3 apf, [datumExample1, redeemerExample1, context], @@ -2039,11 +2090,11 @@ collectTwoPhaseScriptInputsOutputOrdering = ) ] where - apf = Alonzo Mock context = valContext ( fromRight (error "translation error") . runIdentity $ - txInfo + getTxInfo + apf (pp apf) PlutusV1 testEpochInfo @@ -2057,7 +2108,7 @@ collectOrderingAlonzo :: TestTree collectOrderingAlonzo = testCase "collectTwoPhaseScriptInputs output order" - collectTwoPhaseScriptInputsOutputOrdering + (collectTwoPhaseScriptInputsOutputOrdering (Alonzo Mock)) -- ======================= -- Alonzo BBODY Tests @@ -2205,12 +2256,12 @@ testEvaluateTransactionFee = pparams = newPParams pf $ defaultPPs ++ [MinfeeA 1] validatingTxNoWits = newTx - Override + override pf [ Body (validatingBody pf), - Witnesses' - [ ScriptWits [always 3 pf], - DataWits [datumExample1], + WitnessesI + [ ScriptWits' [always 3 pf], + DataWits' [datumExample1], RdmrWits validatingRedeemersEx1 ] ] 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 new file mode 100644 index 00000000000..7a89ec9a202 --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs @@ -0,0 +1,616 @@ +-- fromMap and toMap for Scripts +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Cardano.Ledger.Generic.Fields + ( TxField (.., AuxData', Valid'), + TxBodyField + ( .., + Inputs', + Collateral', + RefInputs', + Outputs', + Certs', + CollateralReturn', + Update', + ReqSignerHashes', + WppHash', + AdHash', + Txnetworkid' + ), + WitnessesField (.., AddrWits', BootWits', ScriptWits', DataWits'), + PParamsField (..), + TxOutField (.., DHash', RefScript'), + initVI, + initWdrl, + initValue, + initialTxBody, + initialWitnesses, + initialTx, + initialTxOut, + initialPParams, + valid, + abstractTx, + abstractTxBody, + abstractTxOut, + abstractWitnesses, + ) +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 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 (..)) +import qualified Cardano.Ledger.Babbage.Tx as Babbage (ValidatedTx (..)) +import qualified Cardano.Ledger.Babbage.TxBody as Babbage (Datum (..), TxBody (..), TxOut (..)) +import Cardano.Ledger.BaseTypes (Network (..), NonNegativeInterval, Nonce, ProtVer (..), StrictMaybe (..), UnitInterval) +import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) +import Cardano.Ledger.Era (Era (..), ValidateScript, hashScript) +import Cardano.Ledger.Keys (KeyHash, KeyPair (..), KeyRole (..), hashKey) +import qualified Cardano.Ledger.Mary.Value as Mary (Value (..)) +import Cardano.Ledger.Shelley.Address.Bootstrap (BootstrapWitness (..)) +import qualified Cardano.Ledger.Shelley.PParams as PP (Update) +import Cardano.Ledger.Shelley.Scripts (ScriptHash) +import Cardano.Ledger.Shelley.Tx as Shelley (pattern WitnessSet) +import qualified Cardano.Ledger.Shelley.Tx as Shelley (Tx (..), TxOut (..)) +import Cardano.Ledger.Shelley.TxBody (DCert (..), Wdrl (..), WitVKey (..)) +import qualified Cardano.Ledger.Shelley.TxBody as Shelley (TxBody (..)) +import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) +import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) +import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Ledger.Val (Val (..)) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) +import Data.Default.Class (def) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as Seq (empty, fromList) +import Data.Set (Set) +import qualified Data.Set as Set +import Numeric.Natural (Natural) +import Test.Cardano.Ledger.Generic.Indexed (theKeyPair) +import Test.Cardano.Ledger.Generic.Proof + +-- ======================================================= +-- Fields are used to hold a single field of record. So the Field +-- data type (Core.T era) holds the union of all fields of (Core.T era) +-- across all eras Shelley, Allegra, Mary, Alonzo, Babbage. +-- Pattern constructors (with primed names, like C') allow users to use [a], to stand +-- for (Set a) (Maybe a) (StrictSeq a) (StrictMaybe a) (Map (hash a) a) +-- and hide the conversion details from the user. This is very convenient when +-- using Fields to construct (Core.Txx era) by hand in an era agnostic way. + +data TxField era + = Body (Core.TxBody era) + | BodyI [TxBodyField era] -- Inlines TxBody Fields + | Witnesses (Core.Witnesses era) + | WitnessesI [WitnessesField era] -- Inlines Witnesess Fields + | AuxData (StrictMaybe (Core.AuxiliaryData era)) + | Valid Alonzo.IsValid + +pattern AuxData' :: [(Core.AuxiliaryData era)] -> TxField era + +pattern Valid' :: Bool -> TxField era + +-- ================= +data TxBodyField era + = Inputs (Set (TxIn (Crypto era))) + | Collateral (Set (TxIn (Crypto era))) + | RefInputs (Set (TxIn (Crypto era))) + | Outputs (StrictSeq (Core.TxOut era)) + | CollateralReturn (StrictMaybe (Core.TxOut era)) + | TotalCol Coin + | Certs (StrictSeq (DCert (Crypto era))) + | Wdrls (Wdrl (Crypto era)) + | Txfee Coin + | Vldt ValidityInterval + | Slot SlotNo + | Update (StrictMaybe (PP.Update era)) + | ReqSignerHashes (Set (KeyHash 'Witness (Crypto era))) + | Mint (Core.Value era) + | WppHash (StrictMaybe (Alonzo.ScriptIntegrityHash (Crypto era))) + | AdHash (StrictMaybe (AuxiliaryDataHash (Crypto era))) + | Txnetworkid (StrictMaybe Network) + +pattern Inputs' :: [TxIn (Crypto era)] -> TxBodyField era -- Set + +pattern Collateral' :: [TxIn (Crypto era)] -> TxBodyField era -- Set + +pattern RefInputs' :: [TxIn (Crypto era)] -> TxBodyField era -- Set + +pattern Outputs' :: [Core.TxOut era] -> TxBodyField era -- StrictSeq + +pattern Certs' :: [DCert (Crypto era)] -> TxBodyField era -- StrictSeq + +pattern CollateralReturn' :: [Core.TxOut era] -> TxBodyField era -- 0 or 1 element + +pattern Update' :: [PP.Update era] -> TxBodyField era -- 0 or 1 element + +pattern ReqSignerHashes' :: [KeyHash 'Witness (Crypto era)] -> TxBodyField era -- A set + +pattern WppHash' :: [Alonzo.ScriptIntegrityHash (Crypto era)] -> TxBodyField era -- 0 or 1 element + +pattern AdHash' :: [AuxiliaryDataHash (Crypto era)] -> TxBodyField era -- 0 or 1 element + +pattern Txnetworkid' :: [Network] -> TxBodyField era -- 0 or 1 element + +-- ==================== +data WitnessesField era + = AddrWits (Set (WitVKey 'Witness (Crypto era))) + | BootWits (Set (BootstrapWitness (Crypto era))) + | ScriptWits (Map (ScriptHash (Crypto era)) (Core.Script era)) + | DataWits (TxDats era) + | RdmrWits (Redeemers era) + +pattern AddrWits' :: Era era => [WitVKey 'Witness (Crypto era)] -> WitnessesField era --Set + +pattern BootWits' :: Era era => [BootstrapWitness (Crypto era)] -> WitnessesField era --Set + +pattern ScriptWits' :: forall era. ValidateScript era => [Core.Script era] -> WitnessesField era -- Map + +pattern DataWits' :: Era era => [Data era] -> WitnessesField era -- Map + +-- ================ +data TxOutField era + = Address (Addr (Crypto era)) + | Amount (Core.Value era) + | DHash (StrictMaybe (DataHash (Crypto era))) + | Datum (Babbage.Datum era) + | RefScript (StrictMaybe (Core.Script era)) + +pattern DHash' :: [DataHash (Crypto era)] -> TxOutField era -- 0 or 1 element + +pattern RefScript' :: [Core.Script era] -> TxOutField era -- 0 or 1 element + +-- ================== +data PParamsField era + = MinfeeA (Natural) + | -- | The constant factor for the minimum fee calculation + MinfeeB (Natural) + | -- | Maximal block body size + MaxBBSize (Natural) + | -- | Maximal transaction size + MaxTxSize (Natural) + | -- | Maximal block header size + MaxBHSize (Natural) + | -- | The amount of a key registration deposit + KeyDeposit (Coin) + | -- | The amount of a pool registration deposit + PoolDeposit (Coin) + | -- | epoch bound on pool retirement + EMax (EpochNo) + | -- | Desired number of pools + NOpt (Natural) + | -- | Pool influence + A0 (NonNegativeInterval) + | -- | Monetary expansion + Rho (UnitInterval) + | -- | Treasury expansion + Tau (UnitInterval) + | -- | Decentralization parameter + D (UnitInterval) -- Dropped in Babbage + | -- | Extra entropy + ExtraEntropy (Nonce) -- Dropped in Babbage + | -- | Protocol version + ProtocolVersion (ProtVer) + | -- | Minimum Stake Pool Cost + MinPoolCost (Coin) + | -- | Cost in ada per byte of UTxO storage (instead of _minUTxOValue) + AdaPerUTxOWord (Coin) + | -- | Cost models for non-native script languages + Costmdls ((Map Language CostModel)) + | -- | Prices of execution units (for non-native script languages) + Prices (Prices) + | -- | Max total script execution resources units allowed per tx + MaxTxExUnits (ExUnits) + | -- | Max total script execution resources units allowed per block + MaxBlockExUnits (ExUnits) + | -- | Max size of a Value in an output + MaxValSize (Natural) + | -- | The scaling percentage of the collateral relative to the fee + CollateralPercentage (Natural) + +-- ========================================================================= +-- Era parametric "empty" or initial values. + +initVI :: ValidityInterval +initVI = ValidityInterval SNothing SNothing + +initWdrl :: Wdrl crypto +initWdrl = Wdrl Map.empty + +initValue :: Mary.Value crypto +initValue = (Mary.Value 0 Map.empty) + +initialTxBody :: Era era => Proof era -> Core.TxBody era +initialTxBody (Shelley _) = Shelley.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) (SlotNo 0) SNothing SNothing +initialTxBody (Allegra _) = MA.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) initVI SNothing SNothing (Coin 0) +initialTxBody (Mary _) = MA.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) initVI SNothing SNothing initValue +initialTxBody (Alonzo _) = + Alonzo.TxBody + Set.empty + Set.empty + Seq.empty + Seq.empty + initWdrl + (Coin 0) + initVI + SNothing + Set.empty + initValue + SNothing + SNothing + SNothing +initialTxBody (Babbage _) = + Babbage.TxBody + Set.empty + Set.empty + Set.empty + Seq.empty + SNothing + (Coin 0) + Seq.empty + initWdrl + (Coin 0) + initVI + SNothing + Set.empty + initValue + SNothing + SNothing + SNothing + +initialWitnesses :: Era era => Proof era -> Core.Witnesses era +initialWitnesses (Shelley _) = WitnessSet Set.empty Map.empty Set.empty +initialWitnesses (Allegra _) = WitnessSet Set.empty Map.empty Set.empty +initialWitnesses (Mary _) = WitnessSet Set.empty Map.empty Set.empty +initialWitnesses (Alonzo _) = TxWitness mempty mempty mempty mempty (Redeemers mempty) +initialWitnesses (Babbage _) = TxWitness mempty mempty mempty mempty (Redeemers mempty) + +initialTx :: forall era. Proof era -> Core.Tx era +initialTx era@(Shelley _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing +initialTx era@(Allegra _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing +initialTx era@(Mary _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing +initialTx era@(Alonzo _) = + Alonzo.ValidatedTx + (initialTxBody era) + (initialWitnesses era) + (Alonzo.IsValid True) + SNothing +initialTx era@(Babbage _) = + Babbage.ValidatedTx + (initialTxBody era) + (initialWitnesses era) + (Alonzo.IsValid True) + SNothing + +-- | A Meaningless Addr. +initialAddr :: Era era => Proof era -> Addr (Crypto era) +initialAddr _wit = Addr Testnet pCred sCred + where + (KeyPair svk _ssk) = theKeyPair 0 + pCred = KeyHashObj . hashKey . vKey $ theKeyPair 1 + sCred = StakeRefBase . KeyHashObj . hashKey $ svk + +initialTxOut :: Era era => Proof era -> Core.TxOut era +initialTxOut wit@(Shelley _) = Shelley.TxOut (initialAddr wit) (Coin 0) +initialTxOut wit@(Allegra _) = Shelley.TxOut (initialAddr wit) (Coin 0) +initialTxOut wit@(Mary _) = Shelley.TxOut (initialAddr wit) (inject (Coin 0)) +initialTxOut wit@(Alonzo _) = Alonzo.TxOut (initialAddr wit) (inject (Coin 0)) SNothing +initialTxOut wit@(Babbage _) = Babbage.TxOut (initialAddr wit) (inject (Coin 0)) Babbage.NoDatum SNothing + +initialPParams :: forall era. Proof era -> Core.PParams era +initialPParams (Shelley _) = def +initialPParams (Allegra _) = def +initialPParams (Mary _) = def +initialPParams (Alonzo _) = def +initialPParams (Babbage _) = def + +-- ============================================================ + +abstractTx :: Proof era -> Core.Tx era -> [TxField era] +abstractTx (Babbage _) (Alonzo.ValidatedTx body wit v auxdata) = + [Body body, Witnesses wit, Valid v, AuxData auxdata] +abstractTx (Alonzo _) (Alonzo.ValidatedTx body wit v auxdata) = + [Body body, Witnesses wit, Valid v, AuxData auxdata] +abstractTx (Shelley _) (Shelley.Tx body wit auxdata) = + [Body body, Witnesses wit, AuxData auxdata] +abstractTx (Mary _) (Shelley.Tx body wit auxdata) = + [Body body, Witnesses wit, AuxData auxdata] +abstractTx (Allegra _) (Shelley.Tx body wit auxdata) = + [Body body, Witnesses wit, AuxData auxdata] + +abstractTxBody :: Proof era -> Core.TxBody era -> [TxBodyField era] +abstractTxBody (Alonzo _) (Alonzo.TxBody inp col out cert wdrl fee vldt up req mnt sih adh net) = + [ Inputs inp, + Collateral col, + Outputs out, + Certs cert, + Wdrls wdrl, + Txfee fee, + Vldt vldt, + Update up, + ReqSignerHashes req, + Mint mnt, + WppHash sih, + AdHash adh, + Txnetworkid net + ] +abstractTxBody (Babbage _) (Babbage.TxBody inp col ref out colret totcol cert wdrl fee vldt up req mnt sih adh net) = + [ Inputs inp, + Collateral col, + RefInputs ref, + Outputs out, + CollateralReturn colret, + TotalCol totcol, + Certs cert, + Wdrls wdrl, + Txfee fee, + Vldt vldt, + Update up, + ReqSignerHashes req, + Mint mnt, + WppHash sih, + 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 (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) = + [Inputs inp, Outputs out, Certs cert, Wdrls wdrl, Txfee fee, Vldt vldt, Update up, AdHash adh, Mint mnt] + +abstractWitnesses :: Proof era -> Core.Witnesses era -> [WitnessesField era] +abstractWitnesses (Shelley _) (WitnessSet keys scripts boot) = [AddrWits keys, ScriptWits scripts, BootWits boot] +abstractWitnesses (Allegra _) (WitnessSet keys scripts boot) = [AddrWits keys, ScriptWits scripts, BootWits boot] +abstractWitnesses (Mary _) (WitnessSet keys scripts boot) = [AddrWits keys, ScriptWits scripts, BootWits boot] +abstractWitnesses (Alonzo _) (TxWitness key boot scripts dats red) = + [AddrWits key, ScriptWits scripts, BootWits boot, DataWits dats, RdmrWits red] +abstractWitnesses (Babbage _) (TxWitness key boot scripts dats red) = + [AddrWits key, ScriptWits scripts, BootWits boot, DataWits dats, RdmrWits red] + +abstractTxOut :: Era era => Proof era -> Core.TxOut era -> [TxOutField era] +abstractTxOut (Shelley _) (Shelley.TxOut addr c) = [Address addr, Amount c] +abstractTxOut (Allegra _) (Shelley.TxOut addr c) = [Address addr, Amount c] +abstractTxOut (Mary _) (Shelley.TxOut addr val) = [Address addr, Amount val] +abstractTxOut (Alonzo _) (Alonzo.TxOut addr val d) = [Address addr, Amount val, DHash d] +abstractTxOut (Babbage _) (Babbage.TxOut addr val d refscr) = [Address addr, Amount val, Datum d, RefScript refscr] + +-- ================================================================= +-- coercion functions for defining Primed Field constructor patterns + +valid :: Alonzo.IsValid -> Bool +valid (Alonzo.IsValid b) = b + +toSet :: Ord a => [a] -> Set a +toSet = Set.fromList + +fromSet :: Set a -> [a] +fromSet = Set.toList + +toStrictSeq :: [a] -> StrictSeq a +toStrictSeq x = Seq.fromList x + +fromStrictSeq :: StrictSeq a -> [a] +fromStrictSeq s = foldr (:) [] s + +toStrictMaybe :: [a] -> StrictMaybe a +toStrictMaybe [] = SNothing +toStrictMaybe [x] = SJust x +toStrictMaybe _xs = error ("toStrictMaybe applied to list with 2 or more elements") + +fromStrictMaybe :: StrictMaybe a -> [a] +fromStrictMaybe SNothing = [] +fromStrictMaybe (SJust x) = [x] + +-- Coercing from [T era] to (Map (Hash (T era)) (T era)), for different version of T that are Hashable + +toMapDat :: Era era => [Data era] -> TxDats era +toMapDat ds = TxDats (Map.fromList (map (\d -> (hashData d, d)) ds)) + +fromMapScript :: forall era. Map (ScriptHash (Crypto era)) (Core.Script era) -> [Core.Script era] +fromMapScript m = Map.elems m + +toMapScript :: forall era. ValidateScript era => [Core.Script era] -> Map (ScriptHash (Crypto era)) (Core.Script era) +toMapScript scripts = Map.fromList (map (\s -> (hashScript @era s, s)) scripts) + +-- ============================================================================= +-- Patterns (with primed names, like C') allow users to use [a], to stand +-- for (Set a) (Maybe a) (StrictSeq a) (StrictMaybe a) (Map (hash a) a) +-- The pattern signatures are just underneath the data declarations + +-- ======================== +-- TxBody patterns + +netview :: TxBodyField era -> Maybe [Network] +netview (Txnetworkid x) = Just (fromStrictMaybe x) +netview _ = Nothing + +pattern Txnetworkid' x <- + (netview -> Just x) + where + Txnetworkid' x = Txnetworkid (toStrictMaybe x) + +adhashview :: TxBodyField era -> Maybe [AuxiliaryDataHash (Crypto era)] +adhashview (AdHash x) = Just (fromStrictMaybe x) +adhashview _ = Nothing + +pattern AdHash' x <- + (adhashview -> Just x) + where + AdHash' x = AdHash (toStrictMaybe x) + +wppview :: TxBodyField era -> Maybe [Alonzo.ScriptIntegrityHash (Crypto era)] +wppview (WppHash x) = Just (fromStrictMaybe x) +wppview _ = Nothing + +pattern WppHash' x <- + (wppview -> Just x) + where + WppHash' x = WppHash (toStrictMaybe x) + +signview :: TxBodyField era -> Maybe [KeyHash 'Witness (Crypto era)] +signview (ReqSignerHashes x) = Just (fromSet x) +signview _ = Nothing + +pattern ReqSignerHashes' x <- + (signview -> Just x) + where + ReqSignerHashes' x = ReqSignerHashes (toSet x) + +updateview :: TxBodyField era -> Maybe [PP.Update era] +updateview (Update x) = Just (fromStrictMaybe x) +updateview _ = Nothing + +pattern Update' x <- + (updateview -> Just x) + where + Update' x = Update (toStrictMaybe x) + +certsview :: TxBodyField era -> Maybe [DCert (Crypto era)] +certsview (Certs x) = Just (fromStrictSeq x) +certsview _ = Nothing + +pattern Certs' x <- + (certsview -> Just x) + where + Certs' x = Certs (toStrictSeq x) + +colretview :: TxBodyField era -> Maybe [Core.TxOut era] +colretview (CollateralReturn x) = Just (fromStrictMaybe x) +colretview _ = Nothing + +pattern CollateralReturn' x <- + (colretview -> Just x) + where + CollateralReturn' x = CollateralReturn (toStrictMaybe x) + +outputview :: TxBodyField era -> Maybe [Core.TxOut era] +outputview (Outputs x) = Just (fromStrictSeq x) +outputview _ = Nothing + +pattern Outputs' x <- + (outputview -> Just x) + where + Outputs' x = Outputs (toStrictSeq x) + +inputsview :: TxBodyField era -> Maybe [TxIn (Crypto era)] +inputsview (Inputs x) = Just (fromSet x) +inputsview _ = Nothing + +pattern Inputs' x <- + (inputsview -> Just x) + where + Inputs' x = Inputs (toSet x) + +colview :: TxBodyField era -> Maybe [TxIn (Crypto era)] +colview (Collateral x) = Just (fromSet x) +colview _ = Nothing + +pattern Collateral' x <- + (colview -> Just x) + where + Collateral' x = Collateral (toSet x) + +refview :: TxBodyField era -> Maybe [TxIn (Crypto era)] +refview (RefInputs x) = Just (fromSet x) +refview _ = Nothing + +pattern RefInputs' x <- + (refview -> Just x) + where + RefInputs' x = RefInputs (toSet x) + +-- ============================= +-- Tx patterns + +validview :: TxField era -> Maybe Bool +validview (Valid x) = Just (valid x) +validview _ = Nothing + +pattern Valid' x <- + (validview -> Just x) + where + Valid' x = Valid (Alonzo.IsValid x) + +auxdataview :: TxField era -> Maybe [Core.AuxiliaryData era] +auxdataview (AuxData x) = Just (fromStrictMaybe x) +auxdataview _ = Nothing + +pattern AuxData' x <- + (auxdataview -> Just x) + where + AuxData' x = AuxData (toStrictMaybe x) + +-- ======================= +-- WitnessesField Patterns + +datawitsview :: forall era. Era era => WitnessesField era -> Maybe [Data era] +datawitsview (DataWits (TxDats x)) = Just (Map.elems x) +datawitsview _ = Nothing + +pattern DataWits' x <- + (datawitsview -> Just x) + where + DataWits' x = DataWits (toMapDat x) + +scriptview :: forall era. WitnessesField era -> Maybe [Core.Script era] +scriptview (ScriptWits x) = Just (fromMapScript @era x) +scriptview _ = Nothing + +pattern ScriptWits' x <- + (scriptview -> Just x) + where + ScriptWits' x = ScriptWits (toMapScript @era x) + +addrview :: WitnessesField era -> Maybe [WitVKey 'Witness (Crypto era)] +addrview (AddrWits x) = Just (fromSet x) +addrview _ = Nothing + +pattern AddrWits' x <- + (addrview -> Just x) + where + AddrWits' x = AddrWits (toSet x) + +bootview :: WitnessesField era -> Maybe [BootstrapWitness (Crypto era)] +bootview (BootWits x) = Just (fromSet x) +bootview _ = Nothing + +pattern BootWits' x <- + (bootview -> Just x) + where + BootWits' x = BootWits (toSet x) + +-- ======================================== +-- TxOut patterns + +refscriptview :: TxOutField era -> Maybe [Core.Script era] +refscriptview (RefScript x) = Just (fromStrictMaybe x) +refscriptview _ = Nothing + +pattern RefScript' x <- + (refscriptview -> Just x) + where + RefScript' x = RefScript (toStrictMaybe x) + +dhashview :: TxOutField era -> Maybe [DataHash (Crypto era)] +dhashview (DHash x) = Just (fromStrictMaybe x) +dhashview _ = Nothing + +pattern DHash' x <- + (dhashview -> Just x) + where + DHash' x = DHash (toStrictMaybe x) + +-- ======================= diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Indexed.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Indexed.hs index 6bf0e4f7abb..4ae41d35c31 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Indexed.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Indexed.hs @@ -15,15 +15,15 @@ module Test.Cardano.Ledger.Generic.Indexed where import Cardano.Crypto.DSIGN.Class () -import qualified Cardano.Crypto.Hash as CH import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Language (Language (..)) import Cardano.Ledger.Alonzo.Scripts (Script (..)) +import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core (Value) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) -import qualified Cardano.Ledger.Crypto as CC (Crypto, HASH) +import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Era (..), ValidateScript (..)) import Cardano.Ledger.Hashes (EraIndependentTxBody, ScriptHash (..)) import Cardano.Ledger.Keys @@ -135,7 +135,7 @@ theSKey n = SKey (sKey (theKeyPair @c n)) theKeyHash :: CC.Crypto c => Int -> KeyHash kr c theKeyHash n = hashKey (theVKey n) -theWitVKey :: (CC.Crypto c, Good c) => Int -> SafeHash c EraIndependentTxBody -> WitVKey 'Witness c +theWitVKey :: (GoodCrypto c) => Int -> SafeHash c EraIndependentTxBody -> WitVKey 'Witness c theWitVKey n hash = makeWitnessVKey hash (theKeyPair n) theKeyHashObj :: CC.Crypto crypto => Int -> Credential kr crypto @@ -255,6 +255,10 @@ instance Reflect (AlonzoEra c) => Fixed (Script (AlonzoEra c)) where unique n = (liftC somealonzo) !! n size _ = Just alonzolength +instance Reflect (BabbageEra c) => Fixed (Script (BabbageEra c)) where + unique n = (liftC somealonzo) !! n + size _ = Just alonzolength + -- ============================================== -- Type families (and other Types uniquely determined from type families like Hashes) -- Because we can't make instances over type families, we can't say things like @@ -266,12 +270,14 @@ pickValue n (Shelley _) = unique @Coin n pickValue n (Allegra _) = unique @Coin n pickValue n (Mary _) = unMulti (unique @(MultiAsset era) n) pickValue n (Alonzo _) = unMulti (unique @(MultiAsset era) n) +pickValue n (Babbage _) = unMulti (unique @(MultiAsset era) n) pickScript :: Int -> Proof era -> Core.Script era pickScript n (Shelley c) = somemultisigs c !! n pickScript n (Allegra c) = sometimelocks c !! n pickScript n (Mary c) = sometimelocks c !! n pickScript n (Alonzo c) = somealonzo c !! n +pickScript n (Babbage c) = somealonzo c !! n pickScriptHash :: forall era. Reflect era => Int -> Proof era -> ScriptHash (Crypto era) pickScriptHash n wit = hashScript @era (pickScript n wit) @@ -306,5 +312,3 @@ instance PrettyA (SKey kr c) where instance PrettyA (MultiAsset era) where prettyA (MultiAsset v) = prettyA v - -type Good c = DSignable c (CH.Hash (CC.HASH c) EraIndependentTxBody) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Parametric.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Parametric.hs new file mode 100644 index 00000000000..8edc60094bb --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Parametric.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Abstracting over operations (especially involving PParams) over all concrete eras. +-- These are the operations we need to generate arbitrary transactions in every era. +module Test.Cardano.Ledger.Generic.Parametric where + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..)) +import Cardano.Ledger.Alonzo.Scripts (CostModel (..), ExUnits (..)) +import Cardano.Ledger.Alonzo.Tx + ( ScriptIntegrityHash, + ValidatedTx (..), + hashScriptIntegrity, + minfee, + ) +import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxDats (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams, PParams' (..)) +import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Credential (Credential) +import qualified Cardano.Ledger.Crypto as CC (Crypto) +import Cardano.Ledger.Era (Era (..)) +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.EpochBoundary (obligation) +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley (minfee) +import qualified Cardano.Ledger.Shelley.PParams as Shelley (PParams, PParams' (..)) +import Cardano.Ledger.Shelley.TxBody (PoolParams (..)) +import Cardano.Ledger.UnifiedMap (ViewMap) +import Data.Default.Class (Default (..)) +import Data.List (foldl') +import qualified Data.Map as Map +import Data.Map.Strict (Map) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Set (Set) +import Numeric.Natural (Natural) + +-- ================================================================ + +data Change + = MaxCollateralInputs Natural + | MaxTxExUnits ExUnits + | CollateralPercentage Natural + | MinfeeA Natural + | MinfeeB Natural + | Costmdls (Map Language CostModel) + | MaxValSize Natural + | MaxTxSize Natural + | PoolDeposit Coin + | KeyDeposit Coin + +class (Default (Core.PParams era)) => Parametric era where + maxCollateralInputs' :: Core.PParams era -> Natural + maxTxExUnits' :: Core.PParams era -> ExUnits + collateralPercentage' :: Core.PParams era -> Natural + minfeeA' :: Core.PParams era -> Natural + minfeeB' :: Core.PParams era -> Natural + costmdls' :: Core.PParams era -> Map Language CostModel + maxValSize' :: Core.PParams era -> Natural + maxTxSize' :: Core.PParams era -> Natural + keyDeposit' :: Core.PParams era -> Coin + poolDeposit' :: Core.PParams era -> Coin + + makeChange :: Core.PParams era -> Change -> Core.PParams era + obligation' :: + Core.PParams era -> + ViewMap (Crypto era) (Credential 'Staking (Crypto era)) Coin -> + Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)) -> + Coin + minfee' :: Core.PParams era -> Core.Tx era -> Coin + hashScriptIntegrity' :: + Core.PParams era -> + Set Language -> + Redeemers era -> + TxDats era -> -- (Map.Map (DataHash c) (Data era)) + StrictMaybe (ScriptIntegrityHash (Crypto era)) + hashScriptIntegrity' _pp _l _r _d = SNothing + +makeChanges :: Parametric era => [Change] -> Core.PParams era -> Core.PParams era +makeChanges cs pp = foldl' makeChange pp cs + +-- ==================================== + +instance CC.Crypto c => Parametric (AlonzoEra c) where + maxCollateralInputs' x = _maxCollateralInputs x + maxTxExUnits' x = _maxTxExUnits x + collateralPercentage' x = _collateralPercentage x + minfeeA' x = _minfeeA x + minfeeB' x = _minfeeB x + costmdls' x = _costmdls x + maxValSize' x = _maxValSize x + maxTxSize' x = _maxTxSize x + poolDeposit' x = _poolDeposit x + keyDeposit' x = _keyDeposit x + + makeChange x (MaxCollateralInputs n) = x {_maxCollateralInputs = n} + makeChange x (MaxTxExUnits n) = x {_maxTxExUnits = n} + makeChange x (CollateralPercentage n) = x {_collateralPercentage = n} + makeChange x (MinfeeA n) = x {_minfeeA = n} + makeChange x (MinfeeB n) = x {_minfeeB = n} + makeChange x (Costmdls n) = x {_costmdls = n} + makeChange x (MaxValSize n) = x {_maxValSize = n} + makeChange x (MaxTxSize n) = x {_maxTxSize = n} + makeChange x (PoolDeposit n) = x {_poolDeposit = n} + makeChange x (KeyDeposit n) = x {_keyDeposit = n} + + obligation' = obligation @c @(PParams (AlonzoEra c)) @(ViewMap c) + minfee' = minfee @(AlonzoEra c) @(ValidatedTx) + hashScriptIntegrity' = hashScriptIntegrity + +-- ================================================================ + +instance CC.Crypto c => Parametric (BabbageEra c) where + maxCollateralInputs' x = Babbage._maxCollateralInputs x + maxTxExUnits' x = Babbage._maxTxExUnits x + collateralPercentage' x = Babbage._collateralPercentage x + minfeeA' x = Babbage._minfeeA x + minfeeB' x = Babbage._minfeeB x + costmdls' x = Babbage._costmdls x + maxValSize' x = Babbage._maxValSize x + maxTxSize' x = Babbage._maxTxSize x + poolDeposit' x = Babbage._poolDeposit x + keyDeposit' x = Babbage._keyDeposit x + + makeChange x (MaxCollateralInputs n) = x {Babbage._maxCollateralInputs = n} + makeChange x (MaxTxExUnits n) = x {Babbage._maxTxExUnits = n} + makeChange x (CollateralPercentage n) = x {Babbage._collateralPercentage = n} + makeChange x (MinfeeA n) = x {Babbage._minfeeA = n} + makeChange x (MinfeeB n) = x {Babbage._minfeeB = n} + makeChange x (Costmdls n) = x {Babbage._costmdls = n} + makeChange x (MaxValSize n) = x {Babbage._maxValSize = n} + makeChange x (MaxTxSize n) = x {Babbage._maxTxSize = n} + makeChange x (PoolDeposit n) = x {Babbage._poolDeposit = n} + makeChange x (KeyDeposit n) = x {Babbage._keyDeposit = n} + + obligation' = obligation @c @(Babbage.PParams (BabbageEra c)) @(ViewMap c) + minfee' = minfee @(BabbageEra c) @(ValidatedTx) + hashScriptIntegrity' = hashScriptIntegrity + +-- ================================================================ + +makeChangeS :: Shelley.PParams era -> Change -> Shelley.PParams era +makeChangeS x (MaxCollateralInputs _) = x +makeChangeS x (MaxTxExUnits _) = x +makeChangeS x (CollateralPercentage _) = x +makeChangeS x (MinfeeA n) = x {Shelley._minfeeA = n} +makeChangeS x (MinfeeB n) = x {Shelley._minfeeB = n} +makeChangeS x (Costmdls _) = x +makeChangeS x (MaxValSize _) = x +makeChangeS x (MaxTxSize n) = x {Shelley._maxTxSize = n} +makeChangeS x (PoolDeposit n) = x {Shelley._poolDeposit = n} +makeChangeS x (KeyDeposit n) = x {Shelley._keyDeposit = n} + +instance CC.Crypto c => Parametric (ShelleyEra c) where + maxCollateralInputs' _x = 0 + maxTxExUnits' _x = mempty + collateralPercentage' _x = 0 + minfeeA' x = Shelley._minfeeA x + minfeeB' x = Shelley._minfeeB x + costmdls' _x = Map.empty + maxValSize' _x = 0 + maxTxSize' x = Shelley._maxTxSize x + poolDeposit' x = Shelley._poolDeposit x + keyDeposit' x = Shelley._keyDeposit x + + makeChange = makeChangeS + obligation' = obligation @c @(Shelley.PParams (ShelleyEra c)) @(ViewMap c) + minfee' = Shelley.minfee + hashScriptIntegrity' _pp _l _r _d = SNothing + +-- ================================================================ + +instance CC.Crypto c => Parametric (MaryEra c) where + maxCollateralInputs' _x = 0 + maxTxExUnits' _x = mempty + collateralPercentage' _x = 0 + minfeeA' x = Shelley._minfeeA x + minfeeB' x = Shelley._minfeeB x + costmdls' _x = Map.empty + maxValSize' _x = 0 + maxTxSize' x = Shelley._maxTxSize x + poolDeposit' x = Shelley._poolDeposit x + keyDeposit' x = Shelley._keyDeposit x + + makeChange = makeChangeS + obligation' = obligation @c @(Shelley.PParams (MaryEra c)) @(ViewMap c) + minfee' = Shelley.minfee + hashScriptIntegrity' _pp _l _r _d = SNothing + +-- ================================================================ + +instance CC.Crypto c => Parametric (AllegraEra c) where + maxCollateralInputs' _x = 0 + maxTxExUnits' _x = mempty + collateralPercentage' _x = 0 + minfeeA' x = Shelley._minfeeA x + minfeeB' x = Shelley._minfeeB x + costmdls' _x = Map.empty + maxValSize' _x = 0 + maxTxSize' x = Shelley._maxTxSize x + poolDeposit' x = Shelley._poolDeposit x + keyDeposit' x = Shelley._keyDeposit x + + makeChange = makeChangeS + obligation' = obligation @c @(Shelley.PParams (AllegraEra c)) @(ViewMap c) + minfee' = Shelley.minfee + hashScriptIntegrity' _pp _l _r _d = SNothing diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Proof.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Proof.hs index ef574fdb1cb..85c0d5e4b78 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Proof.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Proof.hs @@ -1,21 +1,36 @@ +-- ifCurrentProof +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- Used for Refect classes +{-# LANGUAGE UndecidableInstances #-} +-- Used for Refect classes +{-# LANGUAGE UndecidableSuperClasses #-} module Test.Cardano.Ledger.Generic.Proof where +import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm) +import qualified Cardano.Crypto.Hash as CH import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Crypto (StandardCrypto) -import qualified Cardano.Ledger.Crypto as CC (Crypto) +import qualified Cardano.Ledger.Crypto as CC (Crypto, DSIGN, HASH) import Cardano.Ledger.Era (Era (..), ValidateScript (..)) +import Cardano.Ledger.Keys (DSignable) import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.TxBody (EraIndependentTxBody) +import Test.Cardano.Ledger.Generic.Parametric (Parametric) import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto) +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (Testable (..), testProperties) -- ================================================= -- GADTs for witnessing Crypto and Era @@ -40,6 +55,10 @@ type AlonzoMock = AlonzoEra Mock type AlonzoReal = AlonzoEra Standard +type BabbageMock = BabbageEra Mock + +type BabbageReal = BabbageEra Standard + data Evidence c where Standard :: Evidence Standard Mock :: Evidence Mock @@ -50,12 +69,14 @@ data Proof era where Mary :: forall c. CC.Crypto c => Evidence c -> Proof (MaryEra c) Allegra :: forall c. CC.Crypto c => Evidence c -> Proof (AllegraEra c) Alonzo :: forall c. CC.Crypto c => Evidence c -> Proof (AlonzoEra c) + Babbage :: forall c. CC.Crypto c => Evidence c -> Proof (BabbageEra c) instance Show (Proof e) where show (Shelley c) = "Shelley " ++ show c show (Allegra c) = "Allegra " ++ show c show (Mary c) = "Mary " ++ show c show (Alonzo c) = "Alonzo " ++ show c + show (Babbage c) = "Babbage " ++ show c instance Show (Evidence c) where show Mock = "Mock" @@ -64,7 +85,13 @@ instance Show (Evidence c) where -- ================================== -- Reflection over Crypto and Era -class CC.Crypto c => ReflectC c where +type GoodCrypto crypto = + ( CC.Crypto crypto, + DSignable crypto (CH.Hash (CC.HASH crypto) EraIndependentTxBody), + DSIGNAlgorithm (CC.DSIGN crypto) + ) + +class (GoodCrypto c) => ReflectC c where evidence :: Evidence c liftC :: forall a. (Evidence c -> a) -> a liftC f = f (evidence @c) @@ -78,7 +105,8 @@ instance ReflectC C_Crypto where class ( Era era, ValidateScript era, - ReflectC (Crypto era) + ReflectC (Crypto era), + Parametric era ) => Reflect era where @@ -86,6 +114,9 @@ class lift :: forall a. (Proof era -> a) -> a lift f = f (reify @era) +instance ReflectC c => Reflect (BabbageEra c) where + reify = Babbage evidence + instance ReflectC c => Reflect (AlonzoEra c) where reify = Alonzo evidence @@ -97,3 +128,43 @@ instance ReflectC c => Reflect (AllegraEra c) where instance ReflectC c => Reflect (ShelleyEra c) where reify = Shelley evidence + +-- =================================================== +-- Tools for building TestTrees for multiple Eras + +data Some f where + Some :: f a -> Some f + +preShelley, preAllegra, preMary, preAlonzo, preBabbage :: CC.Crypto c => Evidence c -> [Some Proof] +preShelley c = [Some (Shelley c)] +preAllegra c = [Some (Allegra c), Some (Shelley c)] +preMary c = [Some (Mary c), Some (Allegra c), Some (Shelley c)] +preAlonzo c = [Some (Alonzo c), Some (Mary c), Some (Allegra c), Some (Shelley c)] +preBabbage c = [Some (Babbage c), Some (Alonzo c), Some (Mary c), Some (Allegra c), Some (Shelley c)] + +postShelley, postAllegra, postMary, postAlonzo, postBabbage :: CC.Crypto c => Evidence c -> [Some Proof] +postShelley c = [Some (Babbage c), Some (Alonzo c), Some (Mary c), Some (Allegra c), Some (Shelley c)] +postAllegra c = [Some (Babbage c), Some (Alonzo c), Some (Mary c), Some (Allegra c)] +postMary c = [Some (Babbage c), Some (Alonzo c), Some (Mary c)] +postAlonzo c = [Some (Babbage c), Some (Alonzo c)] +postBabbage c = [Some (Babbage c)] + +allEra :: Testable p => String -> [Some Proof] -> (forall era. Proof era -> p) -> TestTree +allEra name eras f = testProperties name (map g eras) + where + g (Some era) = (show era, property (f era)) + +ifProof :: Proof era -> [Some Proof] -> a -> a -> a +ifProof proof ps whentrue whenfalse = + if elem (Some proof) ps then whentrue else whenfalse + +ifCurrentProof :: forall era a. Reflect era => [Some Proof] -> a -> a -> a +ifCurrentProof ps t f = ifProof (reify @era) ps t f + +instance Eq (Some Proof) where + (Some (Shelley _)) == (Some (Shelley _)) = True + (Some (Allegra _)) == (Some (Allegra _)) = True + (Some (Mary _)) == (Some (Mary _)) = True + (Some (Alonzo _)) == (Some (Alonzo _)) = True + (Some (Babbage _)) == (Some (Babbage _)) = True + _ == _ = False diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Scriptic.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Scriptic.hs new file mode 100644 index 00000000000..e3df7b8c769 --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Scriptic.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Ledger.Generic.Scriptic where + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.Scripts (Script (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Crypto as CC (Crypto) +import Cardano.Ledger.Era (Era (..), ValidateScript (..)) +import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Mary (MaryEra) +import qualified Cardano.Ledger.Mary.Value as Mary (AssetName (..), PolicyID (..), Value (..)) +import Cardano.Ledger.Shelley (ShelleyEra) +import qualified Cardano.Ledger.Shelley.Scripts as Multi +import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) +import Cardano.Slotting.Slot (SlotNo (..)) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map +import qualified Data.Sequence.Strict as Seq (fromList) +import Numeric.Natural (Natural) +import Test.Cardano.Ledger.Alonzo.Scripts (alwaysFails, alwaysSucceeds) +import Test.Cardano.Ledger.Generic.Indexed (theKeyHash) +import Test.Cardano.Ledger.Generic.Proof + +-- ============================================= +-- Making era parameterized Scripts + +theSlot :: Int -> SlotNo +theSlot n = SlotNo (fromIntegral n) + +class (Era era, ValidateScript era, Eq (Core.Script era), Show (Core.Script era)) => Scriptic era where + always :: Natural -> Proof era -> (Core.Script era) + alwaysAlt :: Natural -> Proof era -> (Core.Script era) + never :: Natural -> Proof era -> (Core.Script era) + require :: KeyHash 'Witness (Crypto era) -> Proof era -> (Core.Script era) + allOf :: [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) + anyOf :: [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) + mOf :: Int -> [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) + +class Scriptic era => PostShelley era where + before :: Int -> Proof era -> Core.Script era + after :: Int -> Proof era -> Core.Script era + +class HasTokens era where + forge :: Integer -> Core.Script era -> Core.Value era + +instance CC.Crypto c => Scriptic (ShelleyEra c) where + never _ (Shelley _) = Multi.RequireAnyOf mempty -- always False + always _ (Shelley _) = Multi.RequireAllOf mempty -- always True + alwaysAlt _ (Shelley _) = Multi.RequireAllOf mempty -- always True + require key (Shelley _) = Multi.RequireSignature key + allOf xs (Shelley c) = (Multi.RequireAllOf (map ($ Shelley c) xs)) + anyOf xs (Shelley c) = (Multi.RequireAnyOf (map ($ Shelley c) xs)) + mOf n xs (Shelley c) = (Multi.RequireMOf n (map ($ Shelley c) xs)) + +-- Make Scripts in AllegraEra + +instance CC.Crypto c => Scriptic (AllegraEra c) where + never _ (Allegra _) = RequireAnyOf mempty -- always False + always _ (Allegra _) = RequireAllOf mempty -- always True + alwaysAlt _ (Allegra _) = RequireAllOf mempty -- always True + require key (Allegra _) = RequireSignature key + allOf xs (Allegra c) = (RequireAllOf (Seq.fromList (map ($ Allegra c) xs))) + anyOf xs (Allegra c) = (RequireAnyOf (Seq.fromList (map ($ Allegra c) xs))) + mOf n xs (Allegra c) = (RequireMOf n (Seq.fromList (map ($ Allegra c) xs))) + +instance CC.Crypto c => PostShelley (AllegraEra c) where + before n (Allegra _) = RequireTimeStart (theSlot n) + after n (Allegra _) = RequireTimeExpire (theSlot n) + +-- Make Scripts in Mary era + +instance CC.Crypto c => Scriptic (MaryEra c) where + never _ (Mary _) = RequireAnyOf mempty -- always False + always _ (Mary _) = RequireAllOf mempty -- always True + alwaysAlt _ (Mary _) = RequireAllOf mempty -- always True + require key (Mary _) = RequireSignature key + allOf xs (Mary c) = (RequireAllOf (Seq.fromList (map ($ Mary c) xs))) + anyOf xs (Mary c) = (RequireAnyOf (Seq.fromList (map ($ Mary c) xs))) + mOf n xs (Mary c) = (RequireMOf n (Seq.fromList (map ($ Mary c) xs))) + +instance CC.Crypto c => PostShelley (MaryEra c) where + before n (Mary _) = RequireTimeStart (theSlot n) + after n (Mary _) = RequireTimeExpire (theSlot n) + +instance forall c. CC.Crypto c => HasTokens (MaryEra c) where + forge n s = Mary.Value 0 $ Map.singleton pid (Map.singleton an n) + where + pid = Mary.PolicyID (hashScript @(MaryEra c) s) + an = Mary.AssetName $ BS.pack "an" + +instance forall c. CC.Crypto c => HasTokens (AlonzoEra c) where + forge n s = Mary.Value 0 $ Map.singleton pid (Map.singleton an n) + where + pid = Mary.PolicyID (hashScript @(AlonzoEra c) s) + an = Mary.AssetName $ BS.pack "an" + +-- ================================= +-- Make Scripts in Alonzo era + +-- | Not every Alonzo Script can be used in a Timelock context. +unTime :: CC.Crypto (Crypto era) => Proof era -> (Proof era -> Script era) -> Timelock (Crypto era) +unTime wit f = case f wit of + (TimelockScript x) -> x + (PlutusScript _ "\SOH\NUL\NUL \ACK\SOH") -> (RequireAnyOf mempty) + (PlutusScript _ "\SOH\NUL\NUL \STX\NUL\NUL\DC1") -> (RequireAllOf mempty) + (PlutusScript _ _) -> error ("Plutus script in Timelock context") + +instance CC.Crypto c => Scriptic (AlonzoEra c) where + never n (Alonzo _) = alwaysFails PlutusV1 n -- always False + always n (Alonzo _) = alwaysSucceeds PlutusV1 n -- always True + alwaysAlt n (Alonzo _) = alwaysSucceeds PlutusV2 n -- always True + require key (Alonzo _) = TimelockScript (RequireSignature key) + allOf xs (Alonzo c) = TimelockScript (RequireAllOf (Seq.fromList (map (unTime (Alonzo c)) xs))) + anyOf xs (Alonzo c) = TimelockScript (RequireAnyOf (Seq.fromList (map (unTime (Alonzo c)) xs))) + mOf n xs (Alonzo c) = TimelockScript (RequireMOf n (Seq.fromList (map (unTime (Alonzo c)) xs))) + +instance CC.Crypto c => PostShelley (AlonzoEra c) where + before n (Alonzo _) = TimelockScript $ RequireTimeStart (theSlot n) + after n (Alonzo _) = TimelockScript $ RequireTimeExpire (theSlot n) + +-- ================================= + +instance CC.Crypto c => Scriptic (BabbageEra c) where + never n (Babbage _) = alwaysFails PlutusV1 n -- always False + always n (Babbage _) = alwaysSucceeds PlutusV1 n -- always True + alwaysAlt n (Babbage _) = alwaysSucceeds PlutusV2 n -- always True + require key (Babbage _) = TimelockScript (RequireSignature key) + allOf xs (Babbage c) = TimelockScript (RequireAllOf (Seq.fromList (map (unTime (Babbage c)) xs))) + anyOf xs (Babbage c) = TimelockScript (RequireAnyOf (Seq.fromList (map (unTime (Babbage c)) xs))) + mOf n xs (Babbage c) = TimelockScript (RequireMOf n (Seq.fromList (map (unTime (Babbage c)) xs))) + +instance CC.Crypto c => PostShelley (BabbageEra c) where + before n (Babbage _) = TimelockScript $ RequireTimeStart (theSlot n) + after n (Babbage _) = TimelockScript $ RequireTimeExpire (theSlot n) + +-- ======================================= +-- Some examples that work in multiple Eras +matchkey :: Scriptic era => Int -> Proof era -> Core.Script era +matchkey n era = require (theKeyHash n) era + +test21 :: Scriptic era => Proof era -> Core.Script era +test21 wit = allOf [always 1, matchkey 1, anyOf [matchkey 2, matchkey 3]] $ wit + +test22 :: PostShelley era => Proof era -> Core.Script era +test22 wit = mOf 2 [matchkey 1, before 100, anyOf [matchkey 2, matchkey 3]] $ wit 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 eccb6ea2a52..237601ca7c9 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 @@ -3,6 +3,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +-- +-- Eq (Some Proof) +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} @@ -10,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -20,217 +24,38 @@ module Test.Cardano.Ledger.Generic.Updaters where import Cardano.Crypto.DSIGN.Class () -import Cardano.Ledger.Address (Addr (..)) -import Cardano.Ledger.Allegra (AllegraEra) -import Cardano.Ledger.Alonzo (AlonzoEra) -import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash, Data (..), DataHash, hashData) import Cardano.Ledger.Alonzo.Language (Language (..)) import qualified Cardano.Ledger.Alonzo.PParams as Alonzo (PParams' (..)) -import Cardano.Ledger.Alonzo.Scripts - ( CostModel (..), - ExUnits (..), - Prices (..), - Script (..), - ) import Cardano.Ledger.Alonzo.Tx (hashScriptIntegrity) import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxOut (..)) -import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxDats (..), TxWitness (..), unTxDats) -import Cardano.Ledger.BaseTypes (Network (..), NonNegativeInterval, Nonce, ProtVer (..), StrictMaybe (..), UnitInterval) -import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxDats (..), TxWitness (..)) +import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams' (..)) +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.Credential (Credential (..), StakeReference (..)) -import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Era (..), ValidateScript (..)) -import Cardano.Ledger.Hashes (ScriptHash (..)) +import Cardano.Ledger.Era (Era (..)) import Cardano.Ledger.Keys -import Cardano.Ledger.Mary (MaryEra) -import qualified Cardano.Ledger.Mary.Value as Mary (AssetName (..), PolicyID (..), Value (..)) -import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.Address.Bootstrap (BootstrapWitness (..)) -import qualified Cardano.Ledger.Shelley.PParams as PP (PParams, PParams' (..), Update) -import qualified Cardano.Ledger.Shelley.Scripts as Multi -import Cardano.Ledger.Shelley.Tx as Shelley (WitnessSetHKD (addrWits, bootWits, scriptWits), pattern WitnessSet) +import qualified Cardano.Ledger.Shelley.PParams as PP (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 (DCert (..), Wdrl (..), WitVKey (..)) +import Cardano.Ledger.Shelley.TxBody (Wdrl (..)) import qualified Cardano.Ledger.Shelley.TxBody as Shelley (TxBody (..), TxOut (..)) -import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), ValidityInterval (..)) +import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) -import Cardano.Ledger.TxIn (TxIn (..)) -import Cardano.Ledger.Val (inject, (<+>)) -import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) -import qualified Data.ByteString.Char8 as BS -import Data.Default.Class (def) +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 (empty, fromList) +import qualified Data.Sequence.Strict as Seq (null) import Data.Set (Set) import qualified Data.Set as Set -import Numeric.Natural (Natural) -import Test.Cardano.Ledger.Alonzo.Scripts (alwaysFails, alwaysSucceeds) +import Test.Cardano.Ledger.Generic.Fields import Test.Cardano.Ledger.Generic.Indexed import Test.Cardano.Ledger.Generic.Proof --- ============================================= --- Making era parameterized Scripts - -class (Era era, ValidateScript era) => Scriptic era where - always :: Natural -> Proof era -> (Core.Script era) - alwaysAlt :: Natural -> Proof era -> (Core.Script era) - never :: Natural -> Proof era -> (Core.Script era) - require :: KeyHash 'Witness (Crypto era) -> Proof era -> (Core.Script era) - allOf :: [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) - anyOf :: [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) - mOf :: Int -> [Proof era -> (Core.Script era)] -> Proof era -> (Core.Script era) - -class Scriptic era => PostShelley era where - before :: Int -> Proof era -> Core.Script era - after :: Int -> Proof era -> Core.Script era - -class HasTokens era where - forge :: Integer -> Core.Script era -> Core.Value era - -instance CC.Crypto c => Scriptic (ShelleyEra c) where - never _ (Shelley _) = Multi.RequireAnyOf mempty -- always False - always _ (Shelley _) = Multi.RequireAllOf mempty -- always True - alwaysAlt _ (Shelley _) = Multi.RequireAllOf mempty -- always True - require key (Shelley _) = Multi.RequireSignature key - allOf xs (Shelley c) = (Multi.RequireAllOf (map ($ Shelley c) xs)) - anyOf xs (Shelley c) = (Multi.RequireAnyOf (map ($ Shelley c) xs)) - mOf n xs (Shelley c) = (Multi.RequireMOf n (map ($ Shelley c) xs)) - --- Make Scripts in AllegraEra - -instance CC.Crypto c => Scriptic (AllegraEra c) where - never _ (Allegra _) = RequireAnyOf mempty -- always False - always _ (Allegra _) = RequireAllOf mempty -- always True - alwaysAlt _ (Allegra _) = RequireAllOf mempty -- always True - require key (Allegra _) = RequireSignature key - allOf xs (Allegra c) = (RequireAllOf (Seq.fromList (map ($ Allegra c) xs))) - anyOf xs (Allegra c) = (RequireAnyOf (Seq.fromList (map ($ Allegra c) xs))) - mOf n xs (Allegra c) = (RequireMOf n (Seq.fromList (map ($ Allegra c) xs))) - -instance CC.Crypto c => PostShelley (AllegraEra c) where - before n (Allegra _) = RequireTimeStart (unique @SlotNo n) - after n (Allegra _) = RequireTimeExpire (unique @SlotNo n) - --- Make Scripts in Mary era - -instance CC.Crypto c => Scriptic (MaryEra c) where - never _ (Mary _) = RequireAnyOf mempty -- always False - always _ (Mary _) = RequireAllOf mempty -- always True - alwaysAlt _ (Mary _) = RequireAllOf mempty -- always True - require key (Mary _) = RequireSignature key - allOf xs (Mary c) = (RequireAllOf (Seq.fromList (map ($ Mary c) xs))) - anyOf xs (Mary c) = (RequireAnyOf (Seq.fromList (map ($ Mary c) xs))) - mOf n xs (Mary c) = (RequireMOf n (Seq.fromList (map ($ Mary c) xs))) - -instance CC.Crypto c => PostShelley (MaryEra c) where - before n (Mary _) = RequireTimeStart (unique @SlotNo n) - after n (Mary _) = RequireTimeExpire (unique @SlotNo n) - -instance forall c. CC.Crypto c => HasTokens (MaryEra c) where - forge n s = Mary.Value 0 $ Map.singleton pid (Map.singleton an n) - where - pid = Mary.PolicyID (hashScript @(MaryEra c) s) - an = Mary.AssetName $ BS.pack "an" - -instance forall c. CC.Crypto c => HasTokens (AlonzoEra c) where - forge n s = Mary.Value 0 $ Map.singleton pid (Map.singleton an n) - where - pid = Mary.PolicyID (hashScript @(AlonzoEra c) s) - an = Mary.AssetName $ BS.pack "an" - --- Make Scripts in Alonzo era - --- | Not every Alonzo Script can be used in a Timelock context. -unTime :: CC.Crypto (Crypto era) => Proof era -> (Proof era -> Script era) -> Timelock (Crypto era) -unTime wit f = case f wit of - (TimelockScript x) -> x - (PlutusScript _ "\SOH\NUL\NUL \ACK\SOH") -> (RequireAnyOf mempty) - (PlutusScript _ "\SOH\NUL\NUL \STX\NUL\NUL\DC1") -> (RequireAllOf mempty) - (PlutusScript _ _) -> error ("Plutus script in Timelock context") - -instance CC.Crypto c => Scriptic (AlonzoEra c) where - never n (Alonzo _) = alwaysFails PlutusV1 n -- always False - always n (Alonzo _) = alwaysSucceeds PlutusV1 n -- always True - alwaysAlt n (Alonzo _) = alwaysSucceeds PlutusV2 n -- always True - require key (Alonzo _) = TimelockScript (RequireSignature key) - allOf xs (Alonzo c) = TimelockScript (RequireAllOf (Seq.fromList (map (unTime (Alonzo c)) xs))) - anyOf xs (Alonzo c) = TimelockScript (RequireAnyOf (Seq.fromList (map (unTime (Alonzo c)) xs))) - mOf n xs (Alonzo c) = TimelockScript (RequireMOf n (Seq.fromList (map (unTime (Alonzo c)) xs))) - -instance CC.Crypto c => PostShelley (AlonzoEra c) where - before n (Alonzo _) = TimelockScript $ RequireTimeStart (unique @SlotNo n) - after n (Alonzo _) = TimelockScript $ RequireTimeExpire (unique @SlotNo n) - --- Some examples that work in multiple Eras -matchkey :: Scriptic era => Int -> Proof era -> Core.Script era -matchkey n era = require (theKeyHash n) era - -test21 :: Scriptic era => Proof era -> Core.Script era -test21 wit = allOf [always 1, matchkey 1, anyOf [matchkey 2, matchkey 3]] $ wit - -test22 :: PostShelley era => Proof era -> Core.Script era -test22 wit = mOf 2 [matchkey 1, before 100, anyOf [matchkey 2, matchkey 3]] $ wit - --- ========================================================================= --- Era parametric "empty" or initial values. - -initVI :: ValidityInterval -initVI = ValidityInterval SNothing SNothing - -initWdrl :: Wdrl crypto -initWdrl = Wdrl Map.empty - -initValue :: Mary.Value crypto -initValue = (Mary.Value 0 Map.empty) - -initialTxBody :: Era era => Proof era -> Core.TxBody era -initialTxBody (Shelley _) = Shelley.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) (SlotNo 0) SNothing SNothing -initialTxBody (Allegra _) = MA.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) initVI SNothing SNothing (Coin 0) -initialTxBody (Mary _) = MA.TxBody Set.empty Seq.empty Seq.empty initWdrl (Coin 0) initVI SNothing SNothing initValue -initialTxBody (Alonzo _) = - Alonzo.TxBody - Set.empty - Set.empty - Seq.empty - Seq.empty - initWdrl - (Coin 0) - initVI - SNothing - Set.empty - initValue - SNothing - SNothing - SNothing - -initialWitnesses :: Era era => Proof era -> Core.Witnesses era -initialWitnesses (Shelley _) = WitnessSet Set.empty Map.empty Set.empty -initialWitnesses (Allegra _) = WitnessSet Set.empty Map.empty Set.empty -initialWitnesses (Mary _) = WitnessSet Set.empty Map.empty Set.empty -initialWitnesses (Alonzo _) = TxWitness mempty mempty mempty mempty (Redeemers mempty) - -initialTx :: forall era. Proof era -> Core.Tx era -initialTx era@(Shelley _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing -initialTx era@(Allegra _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing -initialTx era@(Mary _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing -initialTx era@(Alonzo _) = - Alonzo.ValidatedTx - (initialTxBody era) - (initialWitnesses era) - (Alonzo.IsValid True) - SNothing - -initialPParams :: forall era. Proof era -> Core.PParams era -initialPParams (Shelley _) = def -initialPParams (Allegra _) = def -initialPParams (Mary _) = def -initialPParams (Alonzo _) = def - -- =========================================================================== -- Upaters and the use of Policy to specify Merge Semantics and use of [t] as inputs. -- When using the Updaters, one will usually consruct the fields by hand. @@ -243,112 +68,45 @@ initialPParams (Alonzo _) = def -- Users may choose what merge semantics they want by passing the right Policy -- ============================================================================= -data Policy - = -- | Combine old and new values using Semigroup semantics (or raise an error if (Semgroup t) doesn't hold). - Merge - | -- | Always use the new value - Override - | -- | Combine old and new, but don't add any new values if they are already in old. - NoDups +-- ======================================================================= +-- A Policy lets you choose to keep the old (first) or the new (override) +-- whenever we have duplicate fields + +type Policy = (forall x. x -> x -> x) --- | filter out elements of 'xs' that are in 't' -nodups :: (Foldable t, Eq x) => t x -> [x] -> [x] -nodups t xs = filter (not . (`elem` t)) xs +first :: Policy +first x _y = x + +override :: Policy +override _x y = y class Merge t x | t -> x where - merge :: t -> [x] -> t - merge t xs = applyMerge Merge t xs - applyMerge :: Policy -> t -> [x] -> t - -instance (Show x, Eq x, Semigroup x) => Merge (Maybe x) x where - applyMerge Merge Nothing [x] = Just x - applyMerge Merge Nothing [] = Nothing - applyMerge Merge (Just x) [y] = Just (x <> y) - applyMerge Merge (Just x) [] = Just x - applyMerge Override Nothing [x] = Just x - applyMerge Override Nothing [] = Nothing - applyMerge Override (Just _) [y] = Just y - applyMerge Override (Just x) [] = Just x - applyMerge NoDups Nothing [x] = Just x - applyMerge NoDups Nothing [] = Nothing - applyMerge NoDups (Just x) [y] = Just (if x == y then x else y) - applyMerge NoDups (Just x) [] = Just x - applyMerge _ _ xs = - error ("Only null lists or lists with 1 element can be used in applyMerge for Maybe: " ++ show xs) - -instance (Show x, Eq x, Semigroup x) => Merge (StrictMaybe x) x where - applyMerge Merge SNothing [x] = SJust x - applyMerge Merge SNothing [] = SNothing - applyMerge Merge (SJust x) [y] = SJust (x <> y) - applyMerge Merge (SJust x) [] = SJust x - applyMerge Override SNothing [x] = SJust x - applyMerge Override SNothing [] = SNothing - applyMerge Override (SJust _) [y] = SJust y - applyMerge Override (SJust x) [] = SJust x - applyMerge NoDups SNothing [x] = SJust x - applyMerge NoDups SNothing [] = SNothing - applyMerge NoDups (SJust x) [y] = SJust (if x == y then x else y) - applyMerge NoDups (SJust x) [] = SJust x - applyMerge _ _ xs = - error ("Only null lists or lists with 1 element can be used in applyMerge for Maybe: " ++ show xs) - -instance Ord x => Merge (Set x) x where - applyMerge Merge set ts = Set.union set (Set.fromList ts) - applyMerge Override _set ts = (Set.fromList ts) - applyMerge NoDups set ts = Set.union set (Set.fromList (nodups set ts)) - -instance Eq x => Merge (StrictSeq x) x where - applyMerge Override _seqx ts = (Seq.fromList ts) - applyMerge Merge seqx ts = seqx <> (Seq.fromList ts) - applyMerge NoDups seqx ts = seqx <> (Seq.fromList (nodups seqx ts)) - -instance Eq x => Merge [x] x where - applyMerge Merge list ts = list ++ ts - applyMerge Override _list ts = ts - applyMerge NoDups list ts = list ++ (nodups list ts) - -instance (Show t, Semigroup t, Show key, Ord key) => Merge (Map key t) (key, t) where - applyMerge Override _m ts = (Map.fromList ts) - applyMerge NoDups m ts = Map.union m (Map.fromList ts) - applyMerge Merge m ts = Map.unionWith (<>) m (Map.fromList ts) - --- | Use this when the range of the map is not a Semigroup. Note Merge cas can fail. -applyMaybe :: Show a => Policy -> Maybe a -> [a] -> Maybe a -applyMap :: (Ord key, Show t, Show key) => String -> Policy -> Map key t -> [(key, t)] -> Map key t -applyMap _ Override _m pairs = Map.fromList pairs -applyMap _ NoDups m ts = Map.union m (Map.fromList ts) -applyMap message Merge m pairs = List.foldl' accum m pairs - where - accum ans (k, t) = Map.insertWithKey checkdisjoint k t ans - checkdisjoint k a b = - error - ( "\nWhile merging maps with supposedly disjoint domains, stored in a field: " ++ message - ++ "\n We found a common domain element: " - ++ show k - ++ "\n With values: " - ++ show a - ++ " and " - ++ show b - ) - --- | Use this when the Maybe type does not have a Semigroup instance -applyMaybe Merge (Just x) [y] = error ("No Semigroup in applyMaybe: " ++ show x ++ " " ++ show y) -applyMaybe _ Nothing [x] = Just x -applyMaybe _ Nothing [] = Nothing -applyMaybe _ (Just _) [y] = Just y -applyMaybe _ (Just x) [] = Just x -applyMaybe _ _ xs = - error ("Only null lists or lists with 1 element can be used in applyMaybe: " ++ show xs) - --- | Use this when the StrictMaybe type does not have a Semigroup instance -applySMaybe :: Show a => Policy -> StrictMaybe a -> [a] -> StrictMaybe a -applySMaybe Merge (SJust x) [y] = error ("No Semigroup in applyStrictMaybe: " ++ show x ++ " " ++ show y) -applySMaybe _ SNothing [x] = SJust x -applySMaybe _ SNothing [] = SNothing -applySMaybe _ (SJust _) [y] = SJust y -applySMaybe _ (SJust x) [] = SJust x -applySMaybe _ _ xs = - error ("Only null lists or lists with 1 element can be used in applyStrictMaybe: " ++ show xs) + merge :: Policy -> t -> t -> t + +instance Merge (Maybe t) t where + merge _ Nothing x = x + merge _ x Nothing = x + merge p x y = p x y + +instance Merge (StrictMaybe t) t where + merge _ SNothing x = x + merge _ x SNothing = x + merge p x y = p 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 -- ==================================================================== -- Building Era parametric Records @@ -356,47 +114,47 @@ applySMaybe _ _ xs = -- Updaters for Tx -data TxField era - = Body (Core.TxBody era) - | Body' [TxBodyField era] - | Witnesses (Core.Witnesses era) - | Witnesses' [WitnessesField era] - | AuxData [(Core.AuxiliaryData era)] -- 0 or 1 element, represents Maybe type - | Valid Bool - updateTx :: Policy -> Proof era -> Core.Tx era -> TxField era -> Core.Tx era updateTx p (wit@(Shelley _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - Body' bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - Witnesses' wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (applySMaybe p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d + AuxData faux -> Shelley.Tx b w (merge p d faux) Valid _ -> tx updateTx p (wit@(Allegra _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - Body' bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - Witnesses' wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (applySMaybe p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d + AuxData faux -> Shelley.Tx b w (merge p d faux) Valid _ -> tx updateTx p (wit@(Mary _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d - Body' bfields -> Shelley.Tx (newTxBody p wit bfields) w d + BodyI bfields -> Shelley.Tx (newTxBody p wit bfields) w d Witnesses fwit -> Shelley.Tx b fwit d - Witnesses' wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (applySMaybe p d faux) + WitnessesI wfields -> Shelley.Tx b (newWitnesses p wit wfields) d + AuxData faux -> Shelley.Tx b w (merge p d faux) Valid _ -> tx updateTx p wit@(Alonzo _) (Alonzo.ValidatedTx b w iv d) dt = case dt of Body fbody -> Alonzo.ValidatedTx fbody w iv d - Body' bfields -> Alonzo.ValidatedTx (newTxBody p wit bfields) w iv d + BodyI bfields -> Alonzo.ValidatedTx (newTxBody p wit bfields) w iv d Witnesses fwit -> Alonzo.ValidatedTx b fwit iv d - Witnesses' wfields -> Alonzo.ValidatedTx b (newWitnesses p wit wfields) iv d - AuxData faux -> Alonzo.ValidatedTx b w iv (applySMaybe p d faux) - Valid iv' -> Alonzo.ValidatedTx b w (Alonzo.IsValid 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 = + case dt of + Body fbody -> Babbage.ValidatedTx fbody w iv d + BodyI bfields -> Babbage.ValidatedTx (newTxBody p 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 newTx :: Policy -> Proof era -> [TxField era] -> Core.Tx era newTx p era = List.foldl' (updateTx p era) (initialTx era) @@ -404,72 +162,77 @@ newTx p era = List.foldl' (updateTx p era) (initialTx era) -------------------------------------------------------------------- -- Updaters for TxBody -data TxBodyField era - = Inputs [TxIn (Crypto era)] - | Collateral [TxIn (Crypto era)] - | Outputs [Core.TxOut era] - | Certs [DCert (Crypto era)] - | Wdrls (Wdrl (Crypto era)) - | Txfee Coin - | Vldt ValidityInterval - | Update [PP.Update era] -- 0 or 1 element, represents Maybe type - | ReqSignerHashes [KeyHash 'Witness (Crypto era)] - | Mint (Core.Value era) - | WppHash [Alonzo.ScriptIntegrityHash (Crypto era)] -- 0 or 1 element, represents Maybe type - | AdHash [AuxiliaryDataHash (Crypto era)] -- 0 or 1 element, represents Maybe type - | Txnetworkid (StrictMaybe Network) - 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 = applyMerge p (Shelley._inputs tx) is} - (Collateral is) -> tx {Shelley._inputs = applyMerge p (Shelley._inputs tx) is} - (Outputs outs) -> tx {Shelley._outputs = applyMerge p (Shelley._outputs tx) outs} - (Certs cs) -> tx {Shelley._certs = applyMerge p (Shelley._certs tx) cs} + (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} - (Update up) -> tx {Shelley._txUpdate = applySMaybe p (Shelley._txUpdate tx) up} - (AdHash hs) -> tx {Shelley._mdHash = applySMaybe p (Shelley._mdHash tx) hs} + (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} _ -> tx updateTxBody p (Allegra _) tx@(MA.TxBody ins outs certs wdrls txfee vldt ups adHash mint) dt = case dt of - (Inputs is) -> MA.TxBody (applyMerge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Collateral is) -> MA.TxBody (applyMerge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Outputs outs1) -> MA.TxBody ins (applyMerge p (MA.outputs' tx) outs1) certs wdrls txfee vldt ups adHash mint - (Certs cs) -> MA.TxBody ins outs (applyMerge p (MA.certs' tx) cs) wdrls txfee vldt ups adHash mint + (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 (Vldt vi) -> MA.TxBody ins outs certs wdrls txfee vi ups adHash mint - (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt (applySMaybe p ups up) adHash mint - (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups (applySMaybe p adHash hs) 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 (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 (applyMerge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Collateral is) -> MA.TxBody (applyMerge p (MA.inputs' tx) is) outs certs wdrls txfee vldt ups adHash mint - (Outputs outs1) -> MA.TxBody ins (applyMerge p (MA.outputs' tx) outs1) certs wdrls txfee vldt ups adHash mint - (Certs cs) -> MA.TxBody ins outs (applyMerge p (MA.certs' tx) cs) wdrls txfee vldt ups adHash mint + (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 (Vldt vi) -> MA.TxBody ins outs certs wdrls txfee vi ups adHash mint - (Update up) -> MA.TxBody ins outs certs wdrls txfee vldt (applySMaybe p ups up) adHash mint - (AdHash hs) -> MA.TxBody ins outs certs wdrls txfee vldt ups (applySMaybe p adHash hs) 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 (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 = applyMerge p (Alonzo.inputs tx) is} - (Collateral is) -> tx {Alonzo.collateral = applyMerge p (Alonzo.collateral tx) is} - (Outputs outs1) -> tx {Alonzo.outputs = applyMerge p (Alonzo.outputs tx) outs1} - (Certs cs) -> tx {Alonzo.txcerts = applyMerge p (Alonzo.txcerts tx) cs} + (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} (Vldt vi) -> tx {Alonzo.txvldt = vi} - (Update up) -> tx {Alonzo.txUpdates = applySMaybe p (Alonzo.txUpdates tx) up} - (ReqSignerHashes hs) -> tx {Alonzo.reqSignerHashes = applyMerge p (Alonzo.reqSignerHashes tx) hs} + (Update up) -> tx {Alonzo.txUpdates = merge p (Alonzo.txUpdates tx) up} + (ReqSignerHashes hs) -> tx {Alonzo.reqSignerHashes = p (Alonzo.reqSignerHashes tx) hs} (Mint v) -> tx {Alonzo.mint = v} - (WppHash h) -> tx {Alonzo.scriptIntegrityHash = applySMaybe p (Alonzo.scriptIntegrityHash tx) h} - (AdHash hs) -> tx {Alonzo.adHash = applySMaybe p (Alonzo.adHash tx) hs} + (WppHash h) -> tx {Alonzo.scriptIntegrityHash = merge p (Alonzo.scriptIntegrityHash tx) h} + (AdHash hs) -> tx {Alonzo.adHash = merge p (Alonzo.adHash tx) 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} + (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} + (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} + (Txnetworkid i) -> tx {Babbage.txnetworkid = i} + (TotalCol coin) -> tx {Babbage.totalCollateral = coin} + (Slot _) -> tx newTxBody :: Era era => Policy -> Proof era -> [TxBodyField era] -> Core.TxBody era newTxBody p era = List.foldl' (updateTxBody p era) (initialTxBody era) @@ -477,98 +240,78 @@ newTxBody p era = List.foldl' (updateTxBody p era) (initialTxBody era) -------------------------------------------------------------------- -- Updaters for Witnesses -data WitnessesField era - = AddrWits [WitVKey 'Witness (Crypto era)] - | BootWits [BootstrapWitness (Crypto era)] - | ScriptWits [Core.Script era] - | DataWits [Data era] - | RdmrWits (Redeemers era) - -hashpair :: - forall era. - (ValidateScript era) => - Proof era -> - Core.Script era -> - (ScriptHash (Crypto era), Core.Script (era)) -hashpair _ x = (hashScript @era x, x) - updateWitnesses :: forall era. Policy -> Proof era -> Core.Witnesses era -> WitnessesField era -> Core.Witnesses era -updateWitnesses p era@(Shelley _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = applyMerge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = applyMerge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = applyMap "ScriptWits" p (Shelley.scriptWits w) (map (hashpair era) ss)} +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} _ -> w -updateWitnesses p era@(Allegra _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = applyMerge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = applyMerge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = applyMap "ScriptWits" p (Shelley.scriptWits w) (map (hashpair era) ss)} +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} _ -> w -updateWitnesses p era@(Mary _) w dw = case dw of - (AddrWits ks) -> w {Shelley.addrWits = applyMerge p (Shelley.addrWits w) ks} - (BootWits boots) -> w {Shelley.bootWits = applyMerge p (Shelley.bootWits w) boots} - (ScriptWits ss) -> w {Shelley.scriptWits = applyMap "ScriptWits" p (Shelley.scriptWits w) (map (hashpair era) ss)} +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} _ -> w -updateWitnesses p wit@(Alonzo _) w dw = case dw of - (AddrWits ks) -> w {txwitsVKey = applyMerge p (txwitsVKey w) ks} - (BootWits boots) -> w {txwitsBoot = applyMerge p (txwitsBoot w) boots} - (ScriptWits ss) -> w {txscripts = applyMap "ScriptWits" p (txscripts w) (map (hashpair wit) ss)} - (DataWits ds) -> - w - { txdats = TxDats $ applyMap "DataWits" p (unTxDats $ txdats w) (map (\x -> (hashData @era x, x)) ds) - } +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} + (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. +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} + (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. newWitnesses :: Era era => Policy -> Proof era -> [WitnessesField era] -> Core.Witnesses era newWitnesses p era = List.foldl' (updateWitnesses p era) (initialWitnesses era) --- ===================================================== +-------------------------------------------------------------------- +-- Updaters for TxOut -data PParamsField era - = MinfeeA (Natural) - | -- | The constant factor for the minimum fee calculation - MinfeeB (Natural) - | -- | Maximal block body size - MaxBBSize (Natural) - | -- | Maximal transaction size - MaxTxSize (Natural) - | -- | Maximal block header size - MaxBHSize (Natural) - | -- | The amount of a key registration deposit - KeyDeposit (Coin) - | -- | The amount of a pool registration deposit - PoolDeposit (Coin) - | -- | epoch bound on pool retirement - EMax (EpochNo) - | -- | Desired number of pools - NOpt (Natural) - | -- | Pool influence - A0 (NonNegativeInterval) - | -- | Monetary expansion - Rho (UnitInterval) - | -- | Treasury expansion - Tau (UnitInterval) - | -- | Decentralization parameter - D (UnitInterval) - | -- | Extra entropy - ExtraEntropy (Nonce) - | -- | Protocol version - ProtocolVersion (ProtVer) - | -- | Minimum Stake Pool Cost - MinPoolCost (Coin) - | -- | Cost in ada per byte of UTxO storage (instead of _minUTxOValue) - AdaPerUTxOWord (Coin) - | -- | Cost models for non-native script languages - Costmdls ((Map Language CostModel)) - | -- | Prices of execution units (for non-native script languages) - Prices (Prices) - | -- | Max total script execution resources units allowed per tx - MaxTxExUnits (ExUnits) - | -- | Max total script execution resources units allowed per block - MaxBlockExUnits (ExUnits) - | -- | Max size of a Value in an output - MaxValSize (Natural) - | -- | The scaling percentage of the collateral relative to the fee - CollateralPercentage (Natural) +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 + Address addr -> Shelley.TxOut addr v + Amount val -> Shelley.TxOut a (v <+> val) + _ -> out +updateTxOut _p (Allegra _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of + Address addr -> Shelley.TxOut addr v + Amount val -> Shelley.TxOut a (v <+> val) + _ -> out +updateTxOut _p (Mary _) (out@(Shelley.TxOut a v)) txoutd = case txoutd of + Address addr -> Shelley.TxOut addr v + Amount val -> Shelley.TxOut a (v <+> val) + _ -> out +updateTxOut p (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) + Datum (Babbage.NoDatum) -> Alonzo.TxOut a v h + Datum (Babbage.DatumHash dh) -> Alonzo.TxOut a v (merge p h (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 + 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) + _ -> 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 + +-- ===================================================== -- | An updater specialized to the Shelley PParams (also used in Allegra and Mary) updateShelleyPP :: PP.PParams era -> PParamsField era -> PP.PParams era @@ -619,66 +362,31 @@ updatePParams (Alonzo _) pp dpp = case dpp of MaxBlockExUnits n -> pp {Alonzo._maxBlockExUnits = n} CollateralPercentage perc -> pp {Alonzo._collateralPercentage = perc} _ -> pp +updatePParams (Babbage _) pp dpp = case dpp of + (MinfeeA nat) -> pp {Babbage._minfeeA = nat} + (MinfeeB nat) -> pp {Babbage._minfeeB = nat} + (MaxBBSize nat) -> pp {Babbage._maxBBSize = nat} + (MaxTxSize nat) -> pp {Babbage._maxTxSize = nat} + (MaxBHSize nat) -> pp {Babbage._maxBHSize = nat} + (KeyDeposit coin) -> pp {Babbage._keyDeposit = coin} + (PoolDeposit coin) -> pp {Babbage._poolDeposit = coin} + (EMax e) -> pp {Babbage._eMax = e} + (NOpt nat) -> pp {Babbage._nOpt = nat} + (A0 rat) -> pp {Babbage._a0 = rat} + (Rho u) -> pp {Babbage._rho = u} + (Tau u) -> pp {Babbage._tau = u} + (ProtocolVersion pv) -> pp {Babbage._protocolVersion = pv} + (MinPoolCost coin) -> pp {Babbage._minPoolCost = coin} + Costmdls cost -> pp {Babbage._costmdls = cost} + 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 newPParams :: Proof era -> [PParamsField era] -> Core.PParams era newPParams era = List.foldl' (updatePParams era) (initialPParams era) --------------------------------------------------------------------- --- Updaters for TxOut - -notAddress :: TxOutField era -> Bool -notAddress (Address _) = False -notAddress _ = True - -applyValue :: Policy -> Proof era -> Core.Value era -> Core.Value era -> Core.Value era -applyValue Override _ _old new = new -applyValue NoDups _ _old new = new -applyValue Merge (Shelley _) old new = old <+> new -applyValue Merge (Allegra _) old new = old <+> new -applyValue Merge (Mary _) old new = old <+> new -applyValue Merge (Alonzo _) old new = old <+> new - -data TxOutField era - = Address (Addr (Crypto era)) - | Amount (Core.Value era) - | DHash [DataHash (Crypto era)] -- 0 or 1 element, represents Maybe type - -updateTxOut :: Policy -> Proof era -> Core.TxOut era -> TxOutField era -> Core.TxOut era -updateTxOut p (Shelley c) (out@(Shelley.TxOut a v)) txoutd = case txoutd of - Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (applyValue p (Shelley c) v val) - _ -> out -updateTxOut p (Allegra c) (out@(Shelley.TxOut a v)) txoutd = case txoutd of - Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (applyValue p (Allegra c) v val) - _ -> out -updateTxOut p (Mary c) (out@(Shelley.TxOut a v)) txoutd = case txoutd of - Address addr -> Shelley.TxOut addr v - Amount val -> Shelley.TxOut a (applyValue p (Mary c) v val) - _ -> out -updateTxOut p (Alonzo c) (Alonzo.TxOut a v h) txoutd = case txoutd of - Address addr -> Alonzo.TxOut addr v h - Amount val -> Alonzo.TxOut a (applyValue p (Alonzo c) v val) h - DHash mdh -> Alonzo.TxOut a v (applySMaybe Merge h mdh) - -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 - --- | A Meaningless Addr. -initialAddr :: Era era => Proof era -> Addr (Crypto era) -initialAddr _wit = Addr Testnet pCred sCred - where - (KeyPair svk _ssk) = theKeyPair 0 - pCred = KeyHashObj . hashKey . vKey $ theKeyPair 1 - sCred = StakeRefBase . KeyHashObj . hashKey $ svk - -initialTxOut :: Era era => Proof era -> Core.TxOut era -initialTxOut wit@(Shelley _) = Shelley.TxOut (initialAddr wit) (Coin 0) -initialTxOut wit@(Allegra _) = Shelley.TxOut (initialAddr wit) (Coin 0) -initialTxOut wit@(Mary _) = Shelley.TxOut (initialAddr wit) (inject (Coin 0)) -initialTxOut wit@(Alonzo _) = Alonzo.TxOut (initialAddr wit) (inject (Coin 0)) SNothing - -- ==================================== -- | This only make sense in the Alonzo era, all other Eras return Nothing @@ -688,12 +396,12 @@ newScriptIntegrityHash :: [Language] -> Redeemers era -> TxDats era -> - [Alonzo.ScriptIntegrityHash (Crypto era)] -- always of length 0 or 1 + StrictMaybe (Alonzo.ScriptIntegrityHash (Crypto era)) newScriptIntegrityHash (Alonzo _) pp ls rds dats = case (hashScriptIntegrity pp (Set.fromList ls) rds dats) of - SJust x -> [x] - SNothing -> [] -newScriptIntegrityHash _wit _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