diff --git a/plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis/Common.hs b/plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis/Common.hs index 34f73dea46..bf1ee9d774 100644 --- a/plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis/Common.hs +++ b/plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis/Common.hs @@ -1,19 +1,12 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} diff --git a/plutus-contract/src/Plutus/Trace/Emulator.hs b/plutus-contract/src/Plutus/Trace/Emulator.hs index 07a5931122..5ca8d3eccc 100644 --- a/plutus-contract/src/Plutus/Trace/Emulator.hs +++ b/plutus-contract/src/Plutus/Trace/Emulator.hs @@ -81,6 +81,7 @@ import Control.Monad.Freer.Extras.Modify (raiseEnd) import Control.Monad.Freer.Reader (Reader, runReader) import Control.Monad.Freer.State (State, evalState) import Control.Monad.Freer.TH (makeEffect) +import Data.Aeson qualified as A import Data.Default (Default (def)) import Data.Map qualified as Map import Data.Maybe (fromMaybe) @@ -122,7 +123,6 @@ import Plutus.Trace.Emulator.Types qualified import Streaming (Stream) import Streaming.Prelude (Of ((:>))) -import Data.Aeson qualified as A import Ledger.Params (Params (..)) import Ledger.Slot (getSlot) import Plutus.V1.Ledger.Value (Value, flattenValue) diff --git a/plutus-contract/src/Plutus/Trace/Scheduler.hs b/plutus-contract/src/Plutus/Trace/Scheduler.hs index bebd7d6f90..42b40398d0 100644 --- a/plutus-contract/src/Plutus/Trace/Scheduler.hs +++ b/plutus-contract/src/Plutus/Trace/Scheduler.hs @@ -286,7 +286,7 @@ runThreads e = do in loop $ initialState & activeThreads . at initialThreadTag . non mempty %~ HashSet.insert initialThreadId - & mailboxes . at initialThreadId .~ Just Seq.empty + & mailboxes . at initialThreadId ?~ Seq.empty & (fst . nextThreadId) & enqueue (suspendThread Normal initialThread) diff --git a/plutus-contract/src/Wallet/Emulator/Folds.hs b/plutus-contract/src/Wallet/Emulator/Folds.hs index 4badc2a571..b7b5970103 100644 --- a/plutus-contract/src/Wallet/Emulator/Folds.hs +++ b/plutus-contract/src/Wallet/Emulator/Folds.hs @@ -59,7 +59,7 @@ import Control.Monad.Freer.Error (Error, throwError) import Data.Aeson qualified as JSON import Data.Foldable (toList) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Ledger (Block, OnChainTx (Invalid, Valid), TxId) @@ -116,7 +116,7 @@ walletTxBalanceEvents = preMapMaybe (preview (eteEvent . walletEvent' . _2 . _Tx -- | Min lovelace of 'txOut's from adjusted unbalanced transactions for all wallets walletsAdjustedTxEvents :: EmulatorEventFold [Ada.Ada] -walletsAdjustedTxEvents = (Set.toList . Set.fromList . concat) <$> preMapMaybe (preview (eteEvent . walletEvent' . _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)) L.list +walletsAdjustedTxEvents = Set.toList . Set.fromList . concat <$> preMapMaybe (preview (eteEvent . walletEvent' . _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)) L.list mkTxLogs :: EmulatorEventFold [MkTxLog] mkTxLogs = @@ -162,7 +162,7 @@ instanceRequests :: -> ContractInstanceTag -> EmulatorEventFoldM effs [Request PABReq] instanceRequests con = fmap g . instanceState con where - g = fromMaybe [] . fmap (State.unRequests . _requests . instContractState) + g = maybe [] (State.unRequests . _requests . instContractState) -- | The unbalanced transactions generated by the contract instance. instanceTransactions :: @@ -175,7 +175,7 @@ instanceTransactions :: -> EmulatorEventFoldM effs [UnbalancedTx] instanceTransactions con = fmap g . instanceState @w @s @e @a @effs con where g :: Maybe (ContractInstanceState w s e a) -> [UnbalancedTx] - g = fromMaybe [] . fmap (mapMaybe (preview _BalanceTxReq . State.rqRequest) . concat . toList . instHandlersHistory) + g = maybe [] (mapMaybe (preview _BalanceTxReq . State.rqRequest) . concat . toList . instHandlersHistory) -- | The reponses received by the contract instance @@ -187,7 +187,7 @@ instanceResponses :: => Contract w s e a -> ContractInstanceTag -> EmulatorEventFoldM effs [Response PABResp] -instanceResponses con = fmap (fromMaybe [] . fmap (toList . instEvents)) . instanceState con +instanceResponses con = fmap (maybe [] (toList . instEvents)) . instanceState con -- | Accumulated state of the contract instance instanceAccumState :: @@ -337,7 +337,7 @@ data EmulatorFoldErr = -- | A human-readable explanation of the error, to be included in the logs. describeError :: EmulatorFoldErr -> String describeError = \case - InstanceStateJSONDecodingError _ _ -> unwords $ + InstanceStateJSONDecodingError _ _ -> unwords [ "Failed to decode a 'Response JSON.Value'." , "The event is probably for a different 'Contract'." , "This is often caused by having multiple contract instances share the same 'ContractInstanceTag' (for example, when using 'activateContractWallet' repeatedly on the same wallet)." diff --git a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs index 0cbf60a4d8..d116a31707 100644 --- a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs +++ b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs @@ -36,6 +36,7 @@ import GHC.Generics (Generic) import Prettyprinter (Pretty (pretty), colon, (<+>)) import Cardano.Api (NetworkId) +import Data.Foldable (fold) import Ledger hiding (to, value) import Ledger.Ada qualified as Ada import Ledger.AddressMap qualified as AM @@ -299,7 +300,7 @@ emulatorStateInitialDist networkId mp = do outs <- traverse (toCardanoTxOut networkId toCardanoTxOutDatum) $ Map.toList mp >>= mkOutputs let tx = mempty { txOutputs = TxOut <$> outs - , txMint = foldMap snd $ Map.toList mp + , txMint = fold mp , txValidRange = WAPI.defaultSlotRange } cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty diff --git a/plutus-contract/src/Wallet/Emulator/Stream.hs b/plutus-contract/src/Wallet/Emulator/Stream.hs index 17e687eb53..907d3cbb91 100644 --- a/plutus-contract/src/Wallet/Emulator/Stream.hs +++ b/plutus-contract/src/Wallet/Emulator/Stream.hs @@ -167,18 +167,15 @@ instance Default EmulatorConfig where initialState :: EmulatorConfig -> EM.EmulatorState initialState EmulatorConfig{..} = let networkId = pNetworkId _params - in either - (either + withInitialWalletValues = either (error . ("Cannot build the initial state: " <>) . show) id - . EM.emulatorStateInitialDist networkId . Map.mapKeys EM.mockWalletPaymentPubKeyHash) - (EM.emulatorStatePool . map signTx) - _initialChainState - where - signTx = onCardanoTx - (\t -> Validation.fromPlutusTxSigned _params cUtxoIndex t CW.knownPaymentKeys) - CardanoApiTx - cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty + . EM.emulatorStateInitialDist networkId . Map.mapKeys EM.mockWalletPaymentPubKeyHash + signTx = onCardanoTx + (\t -> Validation.fromPlutusTxSigned _params cUtxoIndex t CW.knownPaymentKeys) + CardanoApiTx + cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty + in either withInitialWalletValues (EM.emulatorStatePool . map signTx) _initialChainState data EmulatorErr = diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs index 9073dcc1dd..b1496ca719 100644 --- a/plutus-contract/src/Wallet/Emulator/Wallet.hs +++ b/plutus-contract/src/Wallet/Emulator/Wallet.hs @@ -208,8 +208,8 @@ makePrisms ''WalletEvent -- | The state used by the mock wallet environment. data WalletState = WalletState { _mockWallet :: MockWallet, -- ^ Mock wallet with the user's private key. - _nodeClient :: NodeClientState, - _chainIndexEmulatorState :: ChainIndexEmulatorState, + _nodeClient :: NodeClientState, -- ^ The representation of the node, as known by the wallet + _chainIndexEmulatorState :: ChainIndexEmulatorState, -- ^ the chain index info known by the wallet _signingProcess :: Maybe SigningProcess -- ^ Override the signing process. -- Used for testing multi-agent use cases. diff --git a/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs b/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs index 7544183ea2..2309a63765 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs +++ b/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs @@ -9,16 +9,16 @@ {-# 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 import Ledger.Constraints.OnChain.V1 qualified as Constraints import Ledger.Constraints.OnChain.V2 qualified as V2.Constraints -import Ledger.Scripts (ScriptError (EvaluationError)) import Ledger.Test (asDatum, asRedeemer) import Ledger.Tx qualified as Tx import Ledger.Tx.Constraints qualified as Tx.Constraints @@ -34,6 +34,8 @@ import Plutus.V1.Ledger.Value qualified as Value import PlutusTx qualified import PlutusTx.Prelude qualified as P +makeClassyPrisms ''Ledger.ScriptError + -- Constraint's functions should soon be changed to use Address instead of PaymentPubKeyHash and StakeKeyHash tests :: TestTree tests = testGroup "MustPayToPubKeyAddress" @@ -78,6 +80,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 +220,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 +240,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 +267,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 +283,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 +317,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) diff --git a/plutus-contract/test/Spec/TxConstraints/MustReferenceOutput.hs b/plutus-contract/test/Spec/TxConstraints/MustReferenceOutput.hs index 93dd569633..aab3a08ea4 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustReferenceOutput.hs +++ b/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 diff --git a/plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs b/plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs index f29485c88b..e25741509d 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs +++ b/plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs @@ -8,11 +8,10 @@ {-# LANGUAGE TypeFamilies #-} module Spec.TxConstraints.MustSpendPubKeyOutput(tests) where +import Control.Lens (at, non, (^.)) import Control.Monad (void) import Test.Tasty (TestTree, testGroup) -import Control.Lens ((^.)) -import Data.Map qualified as M (elems) import Data.Set (Set) import Data.Set qualified as S (elemAt, elems) import Ledger qualified @@ -31,11 +30,13 @@ import Plutus.Contract as Con import Plutus.Contract.Test (assertContractError, assertFailedTransaction, assertValidatedTransactionCount, checkPredicate, mockWalletPaymentPubKeyHash, w1, w2, walletFundsChange, (.&&.)) import Plutus.Trace qualified as Trace -import Plutus.V1.Ledger.Api (Datum (Datum), ScriptContext, TxOutRef (TxOutRef, txOutRefIdx), Validator, ValidatorHash) +import Plutus.V1.Ledger.Api (Address (addressCredential), Datum (Datum), ScriptContext, TxOutRef (TxOutRef), Validator, + ValidatorHash) import Plutus.V1.Ledger.Scripts (ScriptError (EvaluationError)) import PlutusTx qualified import PlutusTx.Prelude qualified as P -import Wallet.Emulator.Wallet (WalletState, chainIndexEmulatorState, signPrivateKeys, walletToMockWallet') +import Wallet.Emulator.Wallet as Wallet (WalletState, chainIndexEmulatorState, ownAddress, signPrivateKeys, + walletToMockWallet') tests :: TestTree tests = @@ -93,55 +94,10 @@ mustSpendPubKeyOutputContract offChainTxOutRefs onChainTxOutRefs pkh = do mustSpendPubKeyOutputs = Constraints.mustSpendPubKeyOutput <$> offChainTxOutRefs txoRefsFromWalletState :: WalletState -> Set TxOutRef -txoRefsFromWalletState ws = head $ M.elems $ ws ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap +txoRefsFromWalletState w = let + pkCred = addressCredential $ Wallet.ownAddress w + in w ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap . at pkCred . non mempty --- needed to workaround bug 695 -overrideW1TxOutRefs :: [TxOutRef] -> [TxOutRef] -overrideW1TxOutRefs = overrideTxOutRefIdxes 50 - -overrideW2TxOutRefs :: [TxOutRef] -> [TxOutRef] -overrideW2TxOutRefs = overrideTxOutRefIdxes 20 - -overrideTxOutRefIdxes :: Integer -> [TxOutRef] -> [TxOutRef] -overrideTxOutRefIdxes i = fmap (\r@TxOutRef{txOutRefIdx=idx} -> r{txOutRefIdx= idx + i}) --- - -{- --- Example of bug https://github.com/input-output-hk/plutus-apps/issues/695: fails with TxOutRefNotFound because w1 does not have utxo with index of 5 from WalletState -bug695 :: TestTree -bug695 = - let trace = do - w1State <- Trace.agentState w1 - let 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 695" - (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) - (void trace) --} - -{- --- 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 @@ -150,9 +106,8 @@ mustSpendSingleUtxoFromOwnWallet = 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 - void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs overridedW1TxoRefs w1PaymentPubKeyHash - void $ Trace.waitNSlots 1 + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1MiddleTxoRef w1MiddleTxoRef w1PaymentPubKeyHash + void Trace.nextSlot in checkPredicate "Successful use of mustSpendPubKeyOutput with a single txOutRef from own wallet" (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) @@ -165,9 +120,8 @@ mustSpendRemainingInitialUtxosFromOwnWallet = w1State <- Trace.agentState w1 let w1TxoRefs = txoRefsFromWalletState w1State w1RemainingTxoRefs = tail $ S.elems w1TxoRefs - overridedW1TxoRefs = overrideW1TxOutRefs w1RemainingTxoRefs -- need to override index due to bug 695 - void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs overridedW1TxoRefs w1PaymentPubKeyHash - void $ Trace.waitNSlots 1 + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1RemainingTxoRefs w1RemainingTxoRefs w1PaymentPubKeyHash + void Trace.nextSlot in checkPredicate "Successful use of mustSpendPubKeyOutput with all remaining initial txOutRefs from own wallet" (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) @@ -180,10 +134,9 @@ mustSpendSingleUtxoFromOtherWallet = w2State <- Trace.agentState w2 let w2TxoRefs = txoRefsFromWalletState w2State w2MiddleTxoRef = [S.elemAt (length w2TxoRefs `div` 2) w2TxoRefs] - overridedW2TxoRefs = overrideW2TxOutRefs w2MiddleTxoRef -- need to override index due to bug 695 Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ walletToMockWallet' w1, paymentPrivateKey $ walletToMockWallet' w2]) - void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW2TxoRefs overridedW2TxoRefs w2PaymentPubKeyHash - void $ Trace.waitNSlots 1 + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w2MiddleTxoRef w2MiddleTxoRef w2PaymentPubKeyHash + void Trace.nextSlot in checkPredicate "Successful use of mustSpendPubKeyOutput with a single txOutRef from other wallet" (assertValidatedTransactionCount 2 .&&. walletFundsChange w2 (Ada.lovelaceValueOf $ negate lovelacePerInitialUtxo)) @@ -196,10 +149,9 @@ mustSpendAllUtxosFromOtherWallet = w2State <- Trace.agentState w2 let w2TxoRefs = txoRefsFromWalletState w2State allW2TxoRefs = S.elems w2TxoRefs - overridedW2TxoRefs = overrideW2TxOutRefs allW2TxoRefs -- need to override index due to bug 695 Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ walletToMockWallet' w1, paymentPrivateKey $ walletToMockWallet' w2]) - void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW2TxoRefs overridedW2TxoRefs w2PaymentPubKeyHash - void $ Trace.waitNSlots 1 + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract allW2TxoRefs allW2TxoRefs w2PaymentPubKeyHash + void Trace.nextSlot in checkPredicate "Successful use of mustSpendPubKeyOutput with all initial txOutRefs from other wallet" (assertValidatedTransactionCount 2 .&&. walletFundsChange w2 (Ada.lovelaceValueOf $ negate initialLovelacePerWallet)) @@ -211,7 +163,7 @@ contractErrorWhenAttemptingToSpendNonExistentOutput = let contract = mustSpendPubKeyOutputContract [nonExistentTxoRef] [nonExistentTxoRef] w1PaymentPubKeyHash trace = do void $ Trace.activateContractWallet w1 contract - void $ Trace.waitNSlots 1 + void Trace.nextSlot in checkPredicate "Fail validation when mustSpendPubKeyOutput constraint expects a non-existing txo" (assertContractError contract (Trace.walletInstanceTag w1) (\case { ConstraintResolutionContractError ( Constraints.TxOutRefNotFound txoRefInError) -> txoRefInError == nonExistentTxoRef; _ -> False }) "failed to throw error" @@ -225,9 +177,8 @@ phase2FailureWhenTxoIsNotSpent = 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 - void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs [nonExistentTxoRef] w1PaymentPubKeyHash - void $ Trace.waitNSlots 1 + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1MiddleTxoRef [nonExistentTxoRef] w1PaymentPubKeyHash + void Trace.nextSlot in checkPredicate "Fail phase-2 validation when txo expected by on-chain mustSpendPubKeyOutput does not exist" (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("L7":_) _) -> True; _ -> False })) diff --git a/plutus-pab/src/Cardano/Node/Client.hs b/plutus-pab/src/Cardano/Node/Client.hs index 1eccb67bf8..04d51c776c 100644 --- a/plutus-pab/src/Cardano/Node/Client.hs +++ b/plutus-pab/src/Cardano/Node/Client.hs @@ -61,7 +61,7 @@ handleNodeClientClient params e = do Just handle -> liftIO $ onCardanoTx (MockClient.queueTx handle) - (const $ error "Cardano.Node.Client: Expecting a mock tx, not an cardano-api tx when publishing it.") + (const $ error "Cardano.Node.Client: Expecting a mock tx, not a cardano-api tx when publishing it.") tx GetClientSlot -> either (liftIO . MockClient.getCurrentSlot)