Merge pull request #4708 from IntersectMBO/nm/4180-AlonzoValidTxUTXOW…

…-to-ImpTest

Finish implementing the tests in Alonzo.Imp.UtxowSpec.Valid

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs

@@ -19,6 +19,7 @@ import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Allegra.Core
 import Cardano.Ledger.Allegra.Scripts (
   AllegraEraScript,
+  evalTimelock,
   pattern RequireTimeExpire,
   pattern RequireTimeStart,
  )
@@ -55,15 +56,18 @@ instance
   fixupTx = shelleyFixupTx
 
 impAllegraSatisfyNativeScript ::
-  AllegraEraScript era =>
+  ( AllegraEraScript era
+  , AllegraEraTxBody era
+  ) =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
+  TxBody era ->
   NativeScript era ->
   ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
-impAllegraSatisfyNativeScript providedVKeyHashes script = do
+impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do
   impState <- get
   let
     keyPairs = impState ^. impKeyPairsG
-    prevSlotNo = impState ^. impLastTickG
+    vi = txBody ^. vldtTxBodyL
     satisfyMOf m Empty
       | m <= 0 = Just mempty
       | otherwise = Nothing
@@ -82,10 +86,10 @@ impAllegraSatisfyNativeScript providedVKeyHashes script = do
       RequireAllOf ss -> satisfyMOf (length ss) ss
       RequireAnyOf ss -> satisfyMOf 1 ss
       RequireMOf m ss -> satisfyMOf m ss
-      RequireTimeExpire slotNo
-        | slotNo < prevSlotNo -> Just mempty
+      lock@(RequireTimeStart _)
+        | evalTimelock mempty vi lock -> Just mempty
         | otherwise -> Nothing
-      RequireTimeStart slotNo
-        | slotNo > prevSlotNo -> Just mempty
+      lock@(RequireTimeExpire _)
+        | evalTimelock mempty vi lock -> Just mempty
         | otherwise -> Nothing
   pure $ satisfyScript script

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs

@@ -19,6 +19,7 @@ import Cardano.Ledger.Plutus (
  )
 import Control.Monad ((<=<))
 import Lens.Micro ((&), (.~))
+import Test.Cardano.Ledger.Alonzo.Arbitrary ()
 import Test.Cardano.Ledger.Alonzo.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus.Examples
@@ -37,6 +38,7 @@ spec = describe "Valid transactions" $ do
           alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash (EraCrypto era)
           alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash (EraCrypto era)
           alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash (EraCrypto era)
+          alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash (EraCrypto era)
 
         it "Validating SPEND script" $ do
           txIn <- produceScript alwaysSucceedsWithDatumHash
@@ -68,14 +70,24 @@ spec = describe "Valid transactions" $ do
                 & inputsTxBodyL .~ [txIn]
                 & certsTxBodyL .~ [txCert]
 
-  it "Validating WITHDRAWAL script" $ do
-    const $ pendingWith "not implemented yet"
-  it "Not validating WITHDRAWAL script" $ do
-    const $ pendingWith "not implemented yet"
-  it "Validating MINT script" $ do
-    const $ pendingWith "not implemented yet"
-  it "Not validating MINT script" $ do
-    const $ pendingWith "not implemented yet"
+        it "Validating WITHDRAWAL script" $ do
+          account <- registerStakeCredential @era $ ScriptHashObj alwaysSucceedsNoDatumHash
+          expectTxSuccess <=< submitTx $
+            mkBasicTx $
+              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
+
+        it "Not validating WITHDRAWAL script" $ do
+          account <- registerStakeCredential @era $ ScriptHashObj alwaysFailsNoDatumHash
+          expectTxSuccess <=< submitPhase2Invalid $
+            mkBasicTx $
+              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
+
+        it "Validating MINT script" $ do
+          expectTxSuccess <=< submitTx <=< mkTokenMintingTx $ alwaysSucceedsNoDatumHash
+
+        it "Not validating MINT script" $ do
+          expectTxSuccess <=< submitPhase2Invalid <=< mkTokenMintingTx $ alwaysFailsNoDatumHash
+
   it "Validating scripts everywhere" $ do
     const $ pendingWith "not implemented yet"
   it "Acceptable supplimentary datum" $ do

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -515,10 +515,15 @@ submitPhase2Invalid ::
   Tx era ->
   ImpTestM era (Tx era)
 submitPhase2Invalid tx = do
-  (predFailure, fixedUpTx) <- expectLeft =<< trySubmitTx tx
-  scriptPredicateFailure <- impScriptPredicateFailure fixedUpTx
-  predFailure `shouldBeExpr` pure (injectFailure scriptPredicateFailure)
-  withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False
+  fixedUpTx <-
+    impAnn "Check that tx fails with IsValid True" $ do
+      tx ^. isValidTxL `shouldBe` IsValid True
+      (predFailure, fixedUpTx) <- expectLeft =<< trySubmitTx tx
+      scriptPredicateFailure <- impScriptPredicateFailure fixedUpTx
+      predFailure `shouldBeExpr` pure (injectFailure scriptPredicateFailure)
+      pure fixedUpTx
+  impAnn "Submit tx with IsValid False" $ do
+    withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False
 
 expectTxSuccess ::
   ( HasCallStack

eras/conway/impl/CHANGELOG.md

@@ -8,6 +8,7 @@
 
 ### `testlib`
 
+* Remove `mintingTokenTx` (which is replaced by `mkTokenMintingTx` in Mary)
 * Add `minFeeUpdateGovAction`
 * Add `mkTreasuryWithdrawalsGovAction` and `mkParameterChangeGovAction`
 * Switch to using `ImpSpec` package

eras/conway/impl/cardano-ledger-conway.cabal

@@ -163,7 +163,6 @@ library testlib
         cardano-ledger-babbage:{cardano-ledger-babbage, testlib},
         cardano-ledger-conway,
         cardano-ledger-core:{cardano-ledger-core, testlib},
-        cardano-ledger-mary,
         cardano-ledger-shelley:{cardano-ledger-shelley, testlib},
         cardano-strict-containers,
         containers,

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs

@@ -28,11 +28,6 @@ import Cardano.Ledger.Conway.TxInfo
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import Cardano.Ledger.DRep
 import Cardano.Ledger.Keys (KeyRole (..))
-import Cardano.Ledger.Mary.Value (
-  MaryValue (..),
-  MultiAsset (..),
-  PolicyID (..),
- )
 import Cardano.Ledger.Plutus
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
@@ -597,11 +592,10 @@ costModelsSpec =
       govIdConstitution1 <-
         enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMembers'
 
-      let mintingScriptHash = hashPlutusScript (evenRedeemerNoDatum SPlutusV3)
+      mintingTokenTx <- mkTokenMintingTx $ hashPlutusScript (evenRedeemerNoDatum SPlutusV3)
 
       impAnn "Minting token fails" $ do
-        tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) mintingScriptHash
-        submitFailingTx tx [injectFailure $ CollectErrors [NoCostModel PlutusV3]]
+        submitFailingTx mintingTokenTx [injectFailure $ CollectErrors [NoCostModel PlutusV3]]
 
       govIdPPUpdate1 <-
         enactCostModels
@@ -619,8 +613,7 @@ costModelsSpec =
           committeeMembers'
 
       impAnn "Minting token succeeds" $ do
-        tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) mintingScriptHash
-        submitTx_ tx
+        submitTx_ mintingTokenTx
 
       impAnn "Updating CostModels succeeds" $ do
         void $
@@ -695,18 +688,6 @@ testPlutusV1V2Failure sh badField lenz errorField = do
         CollectErrors [BadTranslation errorField]
     )
 
-mintingTokenTx :: ConwayEraImp era => Tx era -> ScriptHash (EraCrypto era) -> ImpTestM era (Tx era)
-mintingTokenTx tx sh = do
-  name <- arbitrary
-  count <- choose (0, 10)
-  let policyId = PolicyID sh
-  let ma = MultiAsset $ Map.singleton policyId [(name, count)]
-  addr <- freshKeyAddr_
-  pure $
-    tx
-      & bodyTxL . mintTxBodyL .~ ma
-      & bodyTxL . outputsTxBodyL <>~ [mkBasicTxOut addr (MaryValue mempty ma)]
-
 enactCostModels ::
   ConwayEraImp era =>
   StrictMaybe (GovPurposeId 'PParamUpdatePurpose era) ->

eras/mary/impl/CHANGELOG.md

@@ -6,6 +6,7 @@
 
 ### `testlib`
 
+* Add `mkTokenMintingTx`
 * Switch to using `ImpSpec` package
 
 ## 1.7.0.1

eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -8,6 +9,7 @@
 module Test.Cardano.Ledger.Mary.ImpTest (
   MaryEraImp,
   module Test.Cardano.Ledger.Allegra.ImpTest,
+  mkTokenMintingTx,
 ) where
 
 import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
@@ -18,8 +20,10 @@ import Cardano.Ledger.Crypto (Crypto (..))
 import Cardano.Ledger.Mary (MaryEra)
 import Cardano.Ledger.Mary.Core
 import Cardano.Ledger.Mary.Value
+import Lens.Micro ((&), (.~))
 import Test.Cardano.Ledger.Allegra.ImpTest
-import Test.Cardano.Ledger.Common
+import Test.Cardano.Ledger.Imp.Common
+import Test.Cardano.Ledger.Mary.Arbitrary ()
 import Test.Cardano.Ledger.Mary.TreeDiff ()
 
 instance
@@ -52,3 +56,15 @@ instance
   , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
   ) =>
   MaryEraImp (MaryEra c)
+
+mkTokenMintingTx :: MaryEraImp era => ScriptHash (EraCrypto era) -> ImpTestM era (Tx era)
+mkTokenMintingTx sh = do
+  name <- arbitrary
+  count <- choose (1, 10)
+  let policyId = PolicyID sh
+  let ma = multiAssetFromList [(policyId, name, count)]
+  addr <- freshKeyAddr_
+  pure $
+    mkBasicTx mkBasicTxBody
+      & bodyTxL . mintTxBodyL .~ ma
+      & bodyTxL . outputsTxBodyL .~ [mkBasicTxOut addr (MaryValue mempty ma)]

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs

@@ -512,6 +512,8 @@ class
   impSatisfyNativeScript ::
     -- | Set of Witnesses that have already been satisfied
     Set.Set (KeyHash 'Witness (EraCrypto era)) ->
+    -- | The transaction body that the script will be applied to
+    TxBody era ->
     NativeScript era ->
     ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
 
@@ -714,7 +716,7 @@ instance
         startEpochNo = impEraStartEpochNo @(ShelleyEra c)
     pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty
 
-  impSatisfyNativeScript providedVKeyHashes script = do
+  impSatisfyNativeScript providedVKeyHashes _txBody script = do
     keyPairs <- gets impKeyPairs
     let
       satisfyMOf m Empty
@@ -863,7 +865,8 @@ updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do
       addrWitHashes = curAddrWitHashes <> Set.map witVKeyHash extraAddrVKeyWits
   -- Shelley Based Native Script Witnesses
   scriptsRequired <- impNativeScriptsRequired tx
-  nativeScriptsKeyPairs <- mapM (impSatisfyNativeScript addrWitHashes) (Map.elems scriptsRequired)
+  nativeScriptsKeyPairs <-
+    mapM (impSatisfyNativeScript addrWitHashes txBody) (Map.elems scriptsRequired)
   let extraNativeScriptVKeyWits =
         mkWitnessesVKey txBodyHash $ Map.elems (mconcat (catMaybes nativeScriptsKeyPairs))
   -- Byron Based Witessed
@@ -903,7 +906,7 @@ impNativeScriptKeyPairs tx = do
   scriptsRequired <- impNativeScriptsRequired tx
   let nativeScripts = Map.elems scriptsRequired
       curAddrWits = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL
-  keyPairs <- mapM (impSatisfyNativeScript curAddrWits) nativeScripts
+  keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts
   pure . mconcat $ catMaybes keyPairs
 
 fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)