From 76669ffb2f4ef0e46b66969750ec18f24870286c Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Mon, 23 May 2022 23:11:20 +0400 Subject: [PATCH] fix tests and some review comments --- plutus-contract/src/Plutus/Contract/Test.hs | 4 ++-- .../Contract/Test/ContractModel/Internal.hs | 6 +++--- .../Test/ContractModel/MissingLovelace.hs | 13 ++++++------- .../src/Plutus/Contract/Trace/RequestHandler.hs | 11 ++++++----- plutus-contract/src/Wallet/API.hs | 13 ++++++------- plutus-contract/src/Wallet/Emulator/Folds.hs | 14 ++++++++++---- .../src/Wallet/Emulator/LogMessages.hs | 3 ++- .../src/Ledger/Constraints/OffChain.hs | 16 +++++++++++----- plutus-ledger/src/Ledger/Validation.hs | 12 ------------ 9 files changed, 46 insertions(+), 46 deletions(-) diff --git a/plutus-contract/src/Plutus/Contract/Test.hs b/plutus-contract/src/Plutus/Contract/Test.hs index 78cb6dd09b..6f5ef91fd7 100644 --- a/plutus-contract/src/Plutus/Contract/Test.hs +++ b/plutus-contract/src/Plutus/Contract/Test.hs @@ -574,11 +574,11 @@ walletFundsExactChange = walletFundsChangeImpl True walletFundsChangeImpl :: Bool -> Wallet -> Value -> TracePredicate walletFundsChangeImpl exact w dlt' = TracePredicate $ - flip postMapM (L.generalize $ (,,) <$> Folds.walletFunds w <*> Folds.walletFees w <*> Folds.walletAdjustedTxEvents) $ \(finalValue', fees, txOutCosts) -> do + flip postMapM (L.generalize $ (,,,) <$> Folds.walletFunds w <*> Folds.walletFees w <*> Folds.walletsAdjustedTxEvents <*> Folds.walletAdjustedTxEvents w) $ \(finalValue', fees, txOutCosts, walletTxOutCosts) -> do dist <- ask @InitialDistribution let initialValue = fold (dist ^. at w) finalValue = finalValue' P.+ if exact then mempty else fees - dlt = calculateDelta dlt' initialValue finalValue w txOutCosts + dlt = calculateDelta dlt' initialValue finalValue w ((w, concat walletTxOutCosts) : txOutCosts) result = initialValue P.+ dlt == finalValue unless result $ do tell @(Doc Void) $ vsep $ diff --git a/plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs b/plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs index 1281b900c2..f7d3a4553f 100644 --- a/plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs +++ b/plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs @@ -1619,7 +1619,7 @@ checkBalances s envOuter = Map.foldrWithKey (\ w sval p -> walletFundsChange w s walletFundsChange w sval = TracePredicate $ -- see Note [The Env contract] flip postMapM ((,) <$> Folds.instanceOutcome @() (toContract getEnvContract) envContractInstanceTag - <*> L.generalize ((,,) <$> Folds.walletFunds w <*> Folds.walletFees w <*> Folds.walletAdjustedTxEvents)) $ \(outcome, (finalValue', fees, txOutCosts)) -> do + <*> L.generalize ((,,,) <$> Folds.walletFunds w <*> Folds.walletFees w <*> Folds.walletsAdjustedTxEvents <*> Folds.walletAdjustedTxEvents w)) $ \(outcome, (finalValue', fees, txOutCosts, walletTxOutCosts)) -> do dist <- Freer.ask @InitialDistribution case outcome of Done envInner -> do @@ -1633,7 +1633,7 @@ checkBalances s envOuter = Map.foldrWithKey (\ w sval p -> walletFundsChange w s initialValue = fold (dist ^. at w) dlt' = toValue lookup sval finalValue = finalValue' P.+ fees - dlt = calculateDelta dlt' initialValue finalValue w txOutCosts + dlt = calculateDelta dlt' initialValue finalValue w ((w, concat walletTxOutCosts) : txOutCosts) result = initialValue P.+ dlt == finalValue unless result $ do tell @(Doc Void) $ vsep $ @@ -1642,7 +1642,7 @@ checkBalances s envOuter = Map.foldrWithKey (\ w sval p -> walletFundsChange w s if initialValue == finalValue then ["but they did not change"] else ["but they changed by", " " <+> viaShow (finalValue P.- initialValue), - "a discrepancy of", " " <+> viaShow (finalValue P.- initialValue P.- dlt)] + "a discrepancy of", " " <+> viaShow (finalValue P.- initialValue P.- dlt) ] pure result _ -> error "I am the pope" diff --git a/plutus-contract/src/Plutus/Contract/Test/ContractModel/MissingLovelace.hs b/plutus-contract/src/Plutus/Contract/Test/ContractModel/MissingLovelace.hs index 068ab8c1ca..fe21765ddf 100644 --- a/plutus-contract/src/Plutus/Contract/Test/ContractModel/MissingLovelace.hs +++ b/plutus-contract/src/Plutus/Contract/Test/ContractModel/MissingLovelace.hs @@ -1,21 +1,20 @@ +{-# LANGUAGE ViewPatterns #-} module Plutus.Contract.Test.ContractModel.MissingLovelace ( calculateDelta ) where -import Data.List as List +import Data.Set qualified as Set import Ledger.Ada qualified as Ada import Ledger.Value (Value, noAdaValue) import PlutusTx.Prelude qualified as P import Wallet.Emulator (Wallet) -calculateDelta :: Value -> Value -> Value -> Wallet -> [(Wallet, [Value])] -> Value -calculateDelta initialDelta initialValue finalValue w txOutCosts = +calculateDelta :: Value -> Value -> Value -> Wallet -> [(Wallet, [Ada.Ada])] -> Value +calculateDelta initialDelta initialValue finalValue w (Set.toList . Set.fromList -> txOutCosts) = let deltas = - let txOutCosts' = case List.uncons $ reverse $ filter ((== w) . fst) txOutCosts of - Just ((_, vs), _) -> map Ada.fromValue vs - _ -> [] - otherWalletsTxOutCosts = concatMap (map Ada.fromValue . snd) $ txOutCosts + let txOutCosts' = concatMap snd $ filter ((== w) . fst) txOutCosts + otherWalletsTxOutCosts = concatMap snd txOutCosts in map P.abs $ concat [ [ P.abs val P.- P.abs wCost , P.abs val P.+ P.abs wCost ] | val <- [Ada.fromValue initialDelta, 0] ++ txOutCosts' diff --git a/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs b/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs index 8bed477bc9..9c4359b1e0 100644 --- a/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs +++ b/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs @@ -43,15 +43,15 @@ import Control.Monad.Freer.NonDet qualified as NonDet import Control.Monad.Freer.Reader (Reader, ask) import Data.Monoid (Alt (Alt), Ap (Ap)) import Data.Text (Text) +import Data.Traversable (forM) import Plutus.Contract.Resumable (Request (Request, itID, rqID, rqRequest), Response (Response, rspItID, rspResponse, rspRqID)) import Control.Monad.Freer.Extras.Log (LogMessage, LogMsg, LogObserve, logDebug, logWarn, surroundDebug) import Ledger (POSIXTime, POSIXTimeRange, Params (..), PaymentPubKeyHash, Slot, SlotRange) -import Ledger.Constraints.OffChain (UnbalancedTx, adjustUnbalancedTx, unBalancedTxTx) +import Ledger.Constraints.OffChain (UnbalancedTx, adjustUnbalancedTx) import Ledger.TimeSlot qualified as TimeSlot -import Ledger.Tx (CardanoTx (EmulatorTx), ToCardanoError) -import Ledger.Validation (getCardanoTxOutputsMissingCosts) +import Ledger.Tx (CardanoTx, ToCardanoError) import Plutus.ChainIndex (ChainIndexQueryEffect) import Plutus.ChainIndex.Effects qualified as ChainIndexEff import Plutus.Contract.Effects (ChainIndexQuery (..), ChainIndexResponse (..)) @@ -269,5 +269,6 @@ handleAdjustUnbalancedTx = RequestHandler $ \utx -> surroundDebug @Text "handleAdjustUnbalancedTx" $ do params <- Wallet.Effects.getClientParams - logDebug $ AdjustingUnbalancedTx $ getCardanoTxOutputsMissingCosts params (EmulatorTx $ unBalancedTxTx utx) - pure $ adjustUnbalancedTx params utx + forM (adjustUnbalancedTx params utx) $ \(missingAdaCosts, adjusted) -> do + logDebug $ AdjustingUnbalancedTx missingAdaCosts + pure adjusted diff --git a/plutus-contract/src/Wallet/API.hs b/plutus-contract/src/Wallet/API.hs index f38a81272e..29ab83e63f 100644 --- a/plutus-contract/src/Wallet/API.hs +++ b/plutus-contract/src/Wallet/API.hs @@ -64,13 +64,12 @@ import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logWarn) import Data.Default (Default (def)) import Data.Text (Text) import Data.Void (Void) -import Ledger (CardanoTx (EmulatorTx), Interval (Interval, ivFrom, ivTo), Params (..), PaymentPubKeyHash, - PubKey (PubKey, getPubKey), PubKeyHash (PubKeyHash, getPubKeyHash), Slot, SlotRange, Value, after, - always, before, contains, interval, isEmpty, member, singleton, width) +import Ledger (CardanoTx, Interval (Interval, ivFrom, ivTo), Params (..), PaymentPubKeyHash, PubKey (PubKey, getPubKey), + PubKeyHash (PubKeyHash, getPubKeyHash), Slot, SlotRange, Value, after, always, before, contains, + interval, isEmpty, member, singleton, width) import Ledger.Constraints qualified as Constraints -import Ledger.Constraints.OffChain (adjustUnbalancedTx, unBalancedTxTx) +import Ledger.Constraints.OffChain (adjustUnbalancedTx) import Ledger.TimeSlot qualified as TimeSlot -import Ledger.Validation (getCardanoTxOutputsMissingCosts) import Wallet.Effects (NodeClientEffect, WalletEffect, balanceTx, getClientParams, getClientSlot, ownPaymentPubKeyHash, publishTx, submitTxn, walletAddSignature, yieldUnbalancedTx) import Wallet.Emulator.LogMessages (RequestHandlerLogMsg (AdjustingUnbalancedTx)) @@ -96,8 +95,8 @@ payToPaymentPublicKeyHash params range v pk = do utx <- either (throwError . PaymentMkTxError) pure (Constraints.mkTx @Void mempty constraints) - adjustedUtx <- either (throwError . ToCardanoError) pure (adjustUnbalancedTx params utx) - logDebug $ AdjustingUnbalancedTx $ getCardanoTxOutputsMissingCosts params (EmulatorTx $ unBalancedTxTx utx) + (missingAdaCosts, adjustedUtx) <- either (throwError . ToCardanoError) pure (adjustUnbalancedTx params utx) + logDebug $ AdjustingUnbalancedTx missingAdaCosts unless (utx == adjustedUtx) $ logWarn @Text $ "Wallet.API.payToPublicKeyHash: " <> "Adjusted a transaction output value which has less than the minimum amount of Ada." diff --git a/plutus-contract/src/Wallet/Emulator/Folds.hs b/plutus-contract/src/Wallet/Emulator/Folds.hs index e210591689..936a790cd8 100644 --- a/plutus-contract/src/Wallet/Emulator/Folds.hs +++ b/plutus-contract/src/Wallet/Emulator/Folds.hs @@ -37,6 +37,7 @@ module Wallet.Emulator.Folds ( , walletFees , walletTxBalanceEvents , walletAdjustedTxEvents + , walletsAdjustedTxEvents -- * Folds that are used in the Playground , annotatedBlockchain , blockchain @@ -79,12 +80,13 @@ import Plutus.Trace.Emulator.ContractInstance (ContractInstanceState, addEventIn instContractState, instEvents, instHandlersHistory) import Plutus.Trace.Emulator.Types (ContractInstanceLog, ContractInstanceMsg (ContractLog), ContractInstanceTag, UserThreadMsg, _HandledRequest, cilMessage, cilTag, toInstanceState) +import Plutus.V1.Ledger.Ada qualified as Ada import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty, vsep) import Prettyprinter.Render.Text (renderStrict) import Wallet.Emulator.Chain (ChainEvent (SlotAdd, TxnValidate, TxnValidationFail), _TxnValidate, _TxnValidationFail) import Wallet.Emulator.LogMessages (_AdjustingUnbalancedTx, _BalancingUnbalancedTx, _ValidationFailed) import Wallet.Emulator.MultiAgent (EmulatorEvent, EmulatorTimeEvent, chainEvent, eteEvent, instanceEvent, - userThreadEvent, walletClientEvent, walletEvent') + userThreadEvent, walletClientEvent, walletEvent, walletEvent') import Wallet.Emulator.NodeClient (_TxSubmit) import Wallet.Emulator.Wallet (Wallet, _RequestHandlerLog, _TxBalanceLog, mockWalletAddress) import Wallet.Rollup qualified as Rollup @@ -121,9 +123,13 @@ scriptEvents = preMapMaybe (preview (eteEvent . chainEvent) >=> getEvent) (conca walletTxBalanceEvents :: EmulatorEventFold [UnbalancedTx] walletTxBalanceEvents = preMapMaybe (preview (eteEvent . walletEvent' . _2 . _TxBalanceLog . _BalancingUnbalancedTx)) L.list --- | Min lovelace of 'txOut's from adjusted unbalanced transactions -walletAdjustedTxEvents :: EmulatorEventFold [(Wallet, [Value])] -walletAdjustedTxEvents = preMapMaybe (preview (eteEvent . walletEvent' . to (\x -> (x ^. _1, x ^. _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)))) L.list +-- | Min lovelace of 'txOut's from adjusted unbalanced transactions for all wallets +walletsAdjustedTxEvents :: EmulatorEventFold [(Wallet, [Ada.Ada])] +walletsAdjustedTxEvents = preMapMaybe (preview (eteEvent . walletEvent' . to (\x -> (x ^. _1, x ^. _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)))) L.list + +-- | Min lovelace of 'txOut's from adjusted unbalanced transactions for the given wallet +walletAdjustedTxEvents :: Wallet -> EmulatorEventFold [[Ada.Ada]] +walletAdjustedTxEvents w = preMapMaybe (preview (eteEvent . walletEvent w . _RequestHandlerLog . _AdjustingUnbalancedTx)) L.list mkTxLogs :: EmulatorEventFold [MkTxLog] mkTxLogs = diff --git a/plutus-contract/src/Wallet/Emulator/LogMessages.hs b/plutus-contract/src/Wallet/Emulator/LogMessages.hs index b67a0189d3..22e9bf71e1 100644 --- a/plutus-contract/src/Wallet/Emulator/LogMessages.hs +++ b/plutus-contract/src/Wallet/Emulator/LogMessages.hs @@ -21,6 +21,7 @@ import Ledger.Constraints.OffChain (UnbalancedTx) import Ledger.Index (ScriptValidationEvent, ValidationError, ValidationPhase) import Ledger.Slot (Slot) import Ledger.Value (Value) +import Plutus.V1.Ledger.Ada qualified as Ada import Prettyprinter (Pretty (..), colon, hang, viaShow, vsep, (<+>)) import Wallet.Emulator.Error (WalletAPIError) @@ -29,7 +30,7 @@ data RequestHandlerLogMsg = | StartWatchingContractAddresses | HandleTxFailed WalletAPIError | UtxoAtFailed Address - | AdjustingUnbalancedTx [Value] + | AdjustingUnbalancedTx [Ada.Ada] deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs index 2e377cfe03..e0bb7d22d3 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs @@ -47,7 +47,7 @@ module Ledger.Constraints.OffChain( , missingValueSpent ) where -import Control.Lens (At (at), iforM_, makeLensesFor, mapMOf, use, view, (%=), (.=), (<>=)) +import Control.Lens (At (at), iforM_, makeLensesFor, mapAccumLOf, use, view, (%=), (.=), (<>=)) import Control.Monad (forM_) import Control.Monad.Except (MonadError (catchError, throwError), runExcept, unless) import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks) @@ -401,14 +401,20 @@ mkTx lookups txc = mkSomeTx [SomeLookupsAndConstraints lookups txc] -- | Each transaction output should contain a minimum amount of Ada (this is a -- restriction on the real Cardano network). -adjustUnbalancedTx :: Params -> UnbalancedTx -> Either Tx.ToCardanoError UnbalancedTx -adjustUnbalancedTx params = mapMOf (tx . Tx.outputs . traverse) adjustTxOut +adjustUnbalancedTx :: Params -> UnbalancedTx -> Either Tx.ToCardanoError ([Ada.Ada], UnbalancedTx) +adjustUnbalancedTx params utx = + let (acc, res) = mapAccumLOf (tx . Tx.outputs . traverse) step (Right []) utx + in (flip (,) res) <$> acc where - adjustTxOut :: TxOut -> Either Tx.ToCardanoError TxOut + step acc txOut = case (acc, adjustTxOut txOut) of + (Left _, _) -> (acc, txOut) -- acc is an error, do nothing + (Right _, Left e) -> (Left e, txOut) -- failed somewhere, return error as acc + (Right acc', Right (ada, txOut')) -> (Right $ ada:acc', txOut') + adjustTxOut :: TxOut -> Either Tx.ToCardanoError (Ada.Ada, TxOut) adjustTxOut txOut = fromPlutusTxOutUnsafe params txOut <&> \txOut' -> let minAdaTxOut' = Ada.fromValue $ evaluateMinLovelaceOutput params txOut' missingLovelace = max 0 (minAdaTxOut' - Ada.fromValue (txOutValue txOut)) - in txOut { txOutValue = txOutValue txOut <> Ada.toValue missingLovelace } + in (missingLovelace, txOut { txOutValue = txOutValue txOut <> Ada.toValue missingLovelace }) -- | Add the remaining balance of the total value that the tx must spend. -- See note [Balance of value spent] diff --git a/plutus-ledger/src/Ledger/Validation.hs b/plutus-ledger/src/Ledger/Validation.hs index 09aad17c14..43bdfcbd35 100644 --- a/plutus-ledger/src/Ledger/Validation.hs +++ b/plutus-ledger/src/Ledger/Validation.hs @@ -39,7 +39,6 @@ module Ledger.Validation( previousBlocks, -- * Etc. emulatorGlobals, - getCardanoTxOutputsMissingCosts ) where import Cardano.Api.Shelley (ShelleyBasedEra (ShelleyBasedEraAlonzo), makeSignedTransaction, shelleyGenesisDefaults, @@ -335,14 +334,3 @@ fromPaymentPrivateKey xprv txBody (C.Api.WitnessPaymentExtendedKey (C.Api.PaymentExtendedSigningKey xprv)) where notUsed = undefined -- hack so we can reuse code from cardano-api - -getCardanoTxOutputsMissingCosts :: P.Params -> P.CardanoTx -> [P.Value] -getCardanoTxOutputsMissingCosts params = getCosts . Map.elems . P.getCardanoTxUnspentOutputsTx - where - getCosts :: [P.TxOut] -> [P.Value] - getCosts txOuts = txOuts <&> \txOut -> case fromPlutusTxOutUnsafe params txOut of - Left _ -> P.zero - Right txOut' -> - let minAdaTxOut' = P.fromValue $ evaluateMinLovelaceOutput params txOut' - missingLovelace = max 0 (minAdaTxOut' - P.fromValue (P.txOutValue txOut)) - in P.toValue missingLovelace