Add solution to #695 to MustReferenceOutput / Remove #696 / harmonize…

… tests

plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs

@@ -9,10 +9,11 @@
 {-# LANGUAGE TypeApplications    #-}
 module Spec.TxConstraints.MustPayToPubKeyAddress(tests) where
 
-import Control.Lens ((??), (^.))
+import Control.Lens (_1, _head, has, makeClassyPrisms, only, (??), (^.))
 import Control.Monad (void)
 import Test.Tasty (TestTree, testGroup)
 
+import Data.Text qualified as Text
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Constraints
@@ -34,6 +35,8 @@ import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import PlutusTx.Prelude qualified as P
 
+makeClassyPrisms ''ScriptError
+
 -- Constraint's functions should soon be changed to use Address instead of PaymentPubKeyHash and StakeKeyHash
 tests :: TestTree
 tests = testGroup "MustPayToPubKeyAddress"
@@ -78,6 +81,9 @@ v2FeaturesNotAvailableTests sub t = testGroup "Plutus V2 features" $
     [ phase1FailureWhenUsingInlineDatumWithV1
     ] ?? sub ?? t
 
+evaluationError :: Text.Text -> Ledger.ValidationError -> Bool
+evaluationError errCode = has $ Ledger._ScriptFailure . _EvaluationError . _1 . _head . only errCode
+
 someDatum :: Ledger.Datum
 someDatum = asDatum @P.BuiltinByteString "datum"
 
@@ -215,8 +221,7 @@ successfulUseOfMustPayWithDatumInTxToPubKeyAddress submitTxFromConstraints tc =
     let onChainConstraint = asRedeemer $ MustPayWithDatumInTxToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
         contract = do
             let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc
-                tx1 =
-                    Constraints.mustPayWithDatumInTxToPubKeyAddress
+                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress
                         w2PaymentPubKeyHash
                         w2StakePubKeyHash
                         someDatum
@@ -236,14 +241,18 @@ phase2FailureWhenUsingUnexpectedPaymentPubKeyHash submitTxFromConstraints tc =
     let onChainConstraint = asRedeemer $ MustPayWithDatumInTxToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
         contract = do
             let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc
-                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress w1PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
+                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress
+                        w1PaymentPubKeyHash
+                        w2StakePubKeyHash
+                        someDatum
+                        adaValue
                    <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc)
             ledgerTx1 <- submitTxFromConstraints lookups1 tx1
             awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected PaymentPubkeyHash"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 -- | Phase-2 failure when onchain mustPayWithDatumInTxToPubKeyAddress constraint cannot verify the Datum"
@@ -259,7 +268,7 @@ phase2FailureWhenUsingUnexpectedDatum submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected Datum"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 -- | Phase-2 failure when onchain mustPayWithDatumInTxToPubKeyAddress constraint cannot verify the Value"
@@ -275,7 +284,7 @@ phase2FailureWhenUsingUnexpectedValue submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected Value"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 
@@ -309,7 +318,7 @@ phase1FailureWhenUsingInlineDatumWithV1 submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-1 failure when mustPayToPubKeyAddress in a V1 script use inline datum"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.CardanoLedgerValidationError _ -> True; _ -> False }))
+    (assertFailedTransaction (const $ has Ledger._CardanoLedgerValidationError))
     (void $ trace contract)
 
 

plutus-contract/test/Spec/TxConstraints/MustReferenceOutput.hs

@@ -10,7 +10,7 @@
 {-# LANGUAGE TypeFamilies        #-}
 module Spec.TxConstraints.MustReferenceOutput(tests) where
 
-import Control.Lens ((??), (^.))
+import Control.Lens (At (at), _1, _head, filtered, has, makeClassyPrisms, non, only, (??), (^.))
 import Control.Monad (void)
 import Test.Tasty (TestTree, testGroup)
 
@@ -23,7 +23,6 @@ import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Cons
 import Ledger.Constraints.OnChain.V1 qualified as Cons.V1
 import Ledger.Constraints.OnChain.V2 qualified as Cons.V2
-import Ledger.Scripts (ScriptError (EvaluationError))
 import Ledger.Test (asDatum, asRedeemer, someAddress, someValidatorHash)
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.Constraints qualified as Tx.Cons
@@ -40,6 +39,9 @@ import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import PlutusTx.Prelude qualified as P
 import Wallet.Emulator.Wallet (WalletState, chainIndexEmulatorState)
+import Wallet.Emulator.Wallet qualified as Wallet
+
+makeClassyPrisms ''L.ScriptError
 
 tests :: TestTree
 tests =
@@ -73,6 +75,9 @@ v2FeaturesTests sub t = testGroup "Plutus V2 features" $
     , phase2FailureWhenUsingV2Script
     ] ?? sub ?? t
 
+evaluationError :: Text.Text -> L.ValidationError -> Bool
+evaluationError errCode = has $ L._ScriptFailure . _EvaluationError . _1 . _head . only errCode
+
 tknValue :: PSU.Language -> Value.Value
 tknValue l = Value.singleton (PSU.scriptCurrencySymbol $ getVersionedScript MustReferenceOutputPolicy l) "mint-me" 1
 
@@ -104,16 +109,9 @@ mustReferenceOutputContract submitTxFromConstraints l offChainTxoRefs onChainTxo
         mustReferenceOutputs = Cons.mustReferenceOutput <$> offChainTxoRefs
 
 txoRefsFromWalletState :: WalletState -> Set Tx.TxOutRef
-txoRefsFromWalletState ws =
-    head $ M.elems $ ws ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap
-
--- needed to workaround bug 695
-overrideW1TxOutRefs :: [Tx.TxOutRef] -> [Tx.TxOutRef]
-overrideW1TxOutRefs = overrideTxOutRefIdxes 50
-
-overrideTxOutRefIdxes :: Integer -> [Tx.TxOutRef] -> [Tx.TxOutRef]
-overrideTxOutRefIdxes i = fmap (\r@Tx.TxOutRef{Tx.txOutRefIdx=idx} -> r{Tx.txOutRefIdx= idx + i})
---
+txoRefsFromWalletState w = let
+  pkCred = L.addressCredential $ Wallet.ownAddress w
+  in w ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap . at pkCred . non mempty
 
 -- | Ledger validation error occurs when attempting use of offchain mustReferenceOutput
 --   constraint with V1 script
@@ -154,8 +152,7 @@ phase2FailureWithMustReferenceOutput testDescription submitTxFromConstraints l =
 
     in checkPredicateOptions defaultCheckOptions
     testDescription
-    (assertFailedTransaction (\_ err ->
-        case err of {L.ScriptFailure (EvaluationError ("Lf":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "Lf")
     (void $ defTrace contractWithoutOffchainConstraint)
 
 -- | Valid scenario using offchain and onchain constraint
@@ -166,10 +163,9 @@ mustReferenceOutputWithSinglePubkeyOutput submitTxFromConstraints l =
             w1State <- Trace.agentState w1
             let w1TxoRefs = txoRefsFromWalletState w1State
                 w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs]
-                overridedW1TxoRefs = overrideW1TxOutRefs w1MiddleTxoRef -- need to override index due to bug 695
                 contract =
                     mustReferenceOutputContract submitTxFromConstraints l
-                    overridedW1TxoRefs overridedW1TxoRefs
+                    w1MiddleTxoRef w1MiddleTxoRef
             void $ Trace.activateContractWallet w1 contract
             void $ Trace.waitNSlots 1
 
@@ -185,11 +181,9 @@ mustReferenceOutputWithMultiplePubkeyOutputs :: SubmitTx -> PSU.Language -> Test
 mustReferenceOutputWithMultiplePubkeyOutputs submitTxFromConstraints l =
     let trace = do
             w1State <- Trace.agentState w1
-            let w1TxoRefs = txoRefsFromWalletState w1State
-                overridedW1TxoRefs = overrideW1TxOutRefs $ S.toList w1TxoRefs -- need to override index due to bug 695
+            let w1TxoRefs = S.toList $ txoRefsFromWalletState w1State
                 contract =
-                    mustReferenceOutputContract submitTxFromConstraints l
-                    overridedW1TxoRefs overridedW1TxoRefs
+                    mustReferenceOutputContract submitTxFromConstraints l w1TxoRefs w1TxoRefs
             void $ Trace.activateContractWallet w1 contract
             void $ Trace.waitNSlots 1
 
@@ -234,9 +228,9 @@ ledgerValidationErrorWhenReferencingNonExistingTxo submitTxFromConstraints l =
     in checkPredicateOptions defaultCheckOptions
     ("Ledger validation error occurs when using offchain mustReferenceOutput " ++
      "constraint with a txo that doesn't exist")
-    (assertFailedTransaction (\_ err ->
-        case err of {L.CardanoLedgerValidationError msg ->
-            Text.isInfixOf "TranslationLogicMissingInput" msg; _ -> False  }))
+    (assertFailedTransaction (const $ has
+        $ L._CardanoLedgerValidationError . filtered (Text.isInfixOf "TranslationLogicMissingInput"))
+    )
     (void $ defTrace contract)
 
 data UnitTest

plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs

@@ -98,26 +98,6 @@ txoRefsFromWalletState w = let
   pkCred = addressCredential $ Wallet.ownAddress w
   in w ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap . at pkCred . non mempty
 
-{-
--- Example of bug https://github.com/input-output-hk/plutus-apps/issues/696
-bug696 :: TestTree
-bug696 =
-    let trace = do
-            thisChainState <- Trace.chainState
-            let traceBlockchain = thisChainState ^. chainNewestFirst
-                traceEmulatorState = emulatorState traceBlockchain
-                walletStateMap = traceEmulatorState ^. walletStates
-                w1State = fromJust $ M.lookup w1 walletStateMap -- Fails here: Maybe.fromJust: Nothing
-
-                w1TxoRefs = txoRefsFromWalletState w1State
-                w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs]
-            void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1MiddleTxoRef w1MiddleTxoRef w1PaymentPubKeyHash
-            void $ Trace.waitNSlots 1
-
-    in checkPredicate "Example of bug 696"
-        (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty)
-        (void trace)
--}
 
 -- | Uses onchain and offchain constraint mustSpendPubKeyOutput to spend a single utxo from own wallet
 mustSpendSingleUtxoFromOwnWallet :: TestTree