Add tests for governance actions

IntersectMBO · Aug 4, 2023 · 7e7d649 · 7e7d649
1 parent 7d05333
commit 7e7d649
Show file tree

Hide file tree

Showing 5 changed files with 424 additions and 1 deletion.
diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal
@@ -45,6 +45,7 @@ library
  Test.Cardano.Ledger.Constrained.Size
  Test.Cardano.Ledger.Constrained.Solver
  Test.Cardano.Ledger.Examples.BabbageFeatures
+ Test.Cardano.Ledger.Examples.ConwayFeatures
  Test.Cardano.Ledger.Examples.AlonzoValidTxUTXOW
  Test.Cardano.Ledger.Examples.AlonzoInvalidTxUTXOW
  Test.Cardano.Ledger.Examples.AlonzoBBODY

diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs
@@ -14,7 +14,16 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Test.Cardano.Ledger.Examples.BabbageFeatures where
+module Test.Cardano.Ledger.Examples.BabbageFeatures (
+ InOut,
+ TestCaseData (..),
+ InitOutputs (..),
+ InitUtxo (..),
+ KeyPairRole (..),
+ txFromTestCaseData,
+ utxoFromTestCaseData,
+ babbageFeatures,
+) where
 
 import qualified Cardano.Crypto.Hash as CH
 import Cardano.Ledger.Address (Addr (..))
@@ -41,6 +50,7 @@ import Cardano.Ledger.Babbage.TxBody (
 import Cardano.Ledger.BaseTypes (
  Network (..),
  StrictMaybe (..),
+ mkTxIx,
  mkTxIxPartial,
  natVersion,
  )
@@ -66,6 +76,7 @@ import Control.State.Transition.Extended hiding (Assertion)
 import qualified Data.ByteString as BS
 import Data.ByteString.Short as SBS (ShortByteString, pack)
 import Data.Default.Class (Default (..))
+import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (maybeToList)
 import qualified Data.Sequence.Strict as StrictSeq
@@ -1047,6 +1058,7 @@ data InitUtxo era = InitUtxo
 data KeyPairRole era
  = KeyPairPayment (KeyPair 'Payment (EraCrypto era))
  | KeyPairWitness (KeyPair 'Witness (EraCrypto era))
+ | KeyPairStakePool (KeyPair 'StakePool (EraCrypto era))
 
 initUtxoFromTestCaseData ::
  BabbageEraTxBody era =>
@@ -1065,6 +1077,28 @@ initUtxoFromTestCaseData
  collateral' = Set.toList collateralIns `zip` ofCollateral'
  in InitUtxo inputs' refInputs' collateral'
 
+utxoFromTestCaseData ::
+ forall era.
+ BabbageEraTxBody era =>
+ Proof era ->
+ TestCaseData era ->
+ (UTxO era, UTxO era)
+utxoFromTestCaseData pf (TestCaseData txBody' (InitOutputs ofInputs' ofRefInputs' ofCollateral') _ _) =
+ let inputsIns = getInputs pf txBody'
+ refInputsIns = txBody' ^. referenceInputsTxBodyL
+ collateralIns = txBody' ^. collateralInputsTxBodyL
+
+ inputs' = Set.toList inputsIns `zip` ofInputs'
+ refInputs' = Set.toList refInputsIns `zip` ofRefInputs'
+ collateral' = Set.toList collateralIns `zip` ofCollateral'
+
+ newTxIns = fmap (TxIn (txid txBody') . mkTxIx) [0 ..] :: [TxIn (EraCrypto era)]
+ newTxInOuts = newTxIns `zip` toList (getOutputs pf txBody')
+
+ initUtxo = UTxO $ Map.fromList (inputs' ++ refInputs' ++ collateral')
+ expectedUtxo = UTxO $ Map.fromList (newTxInOuts ++ refInputs' ++ collateral')
+ in (initUtxo, expectedUtxo)
+
 txFromTestCaseData ::
  forall era.
  ( Scriptic era
@@ -1082,6 +1116,7 @@ txFromTestCaseData
  ( \case
  KeyPairPayment p -> mkWitnessVKey (hashAnnotated (txBody testCaseData)) p
  KeyPairWitness w -> mkWitnessVKey (hashAnnotated (txBody testCaseData)) w
+ KeyPairStakePool s -> mkWitnessVKey (hashAnnotated (txBody testCaseData)) s
  )
  (keysForAddrWits testCaseData)
  tx =