diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-contract.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-contract.nix index e58d71e7ea..0efcae45aa 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-contract.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-contract.nix @@ -191,6 +191,7 @@ ] ++ (pkgs.lib).optional (!(compiler.isGhcjs && true || system.isGhcjs)) (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")); buildable = true; modules = [ + "Spec/Balancing" "Spec/Contract" "Spec/ErrorChecking" "Spec/Emulator" diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-contract.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-contract.nix index e58d71e7ea..0efcae45aa 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-contract.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-contract.nix @@ -191,6 +191,7 @@ ] ++ (pkgs.lib).optional (!(compiler.isGhcjs && true || system.isGhcjs)) (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")); buildable = true; modules = [ + "Spec/Balancing" "Spec/Contract" "Spec/ErrorChecking" "Spec/Emulator" diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-contract.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-contract.nix index e58d71e7ea..0efcae45aa 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-contract.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-contract.nix @@ -191,6 +191,7 @@ ] ++ (pkgs.lib).optional (!(compiler.isGhcjs && true || system.isGhcjs)) (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")); buildable = true; modules = [ + "Spec/Balancing" "Spec/Contract" "Spec/ErrorChecking" "Spec/Emulator" diff --git a/plutus-contract/plutus-contract.cabal b/plutus-contract/plutus-contract.cabal index c257aded5a..0fc4601029 100644 --- a/plutus-contract/plutus-contract.cabal +++ b/plutus-contract/plutus-contract.cabal @@ -182,6 +182,7 @@ test-suite plutus-contract-test -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas hs-source-dirs: test other-modules: + Spec.Balancing Spec.Contract Spec.ErrorChecking Spec.Emulator diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs index fc457f6398..6d4a91a941 100644 --- a/plutus-contract/src/Wallet/Emulator/Wallet.hs +++ b/plutus-contract/src/Wallet/Emulator/Wallet.hs @@ -371,8 +371,7 @@ handleBalanceTx utxo UnbalancedTx{unBalancedTxTx} = do right = fees <> foldMap (view Tx.outValue) (filteredUnbalancedTxTx ^. Tx.outputs) remainingFees = fees PlutusTx.- fold collateral -- TODO: add collateralPercent balance = left PlutusTx.- right - - (neg, pos) <- adjustBalanceWithMissingLovelace utxo ownPaymentPubKey filteredUnbalancedTxTx $ Value.split balance + (neg, pos) = adjustBalanceWithMissingLovelace $ Value.split balance tx' <- if Value.isZero pos then do @@ -405,52 +404,23 @@ handleBalanceTx utxo UnbalancedTx{unBalancedTxTx} = do -- | Adjust the left and right balance of an unbalanced 'Tx' with the missing -- lovelace considering the minimum lovelace per transaction output constraint -- from the Cardano blockchain. -adjustBalanceWithMissingLovelace :: - forall effs. - ( Member ChainIndexQueryEffect effs - , Member (Error WAPI.WalletAPIError) effs - ) - => Map.Map TxOutRef ChainIndexTxOut -- ^ The current wallet's unspent transaction outputs. - -> PaymentPubKey -- ^ Wallet's public key - -> Tx -- ^ An unbalanced tx - -> (Value, Value) -- ^ The unbalanced tx's left and right balance. - -> Eff effs (Value, Value) -- ^ New left and right balance. -adjustBalanceWithMissingLovelace utxo ownPaymentPubKey unBalancedTx (neg, pos) = do - -- Find the tx's input value which refer to the current wallet's address. - let ownPkh = Ledger.pubKeyHash $ unPaymentPubKey ownPaymentPubKey - let pkhOfUnspentTxIn TxIn { txInRef } = - (Ledger.toPubKeyHash . view Ledger.ciTxOutAddress) =<< Map.lookup txInRef utxo - let ownTxInputs = filter (\txIn -> Just ownPkh == pkhOfUnspentTxIn txIn) - (Set.toList $ Tx.txInputs unBalancedTx) - ownInputValues <- traverse lookupValue ownTxInputs - - -- When minting a token, there will be eventually a transaction output - -- with that token. However, it is important to make sure that we can add - -- the minimum lovelace alongside that token value in order to satisfy the - -- Cardano blockchain constraint. Therefore, if there is a minted token, we - -- add the missing lovelace on the positive balance. - let txMintMaybe = if Value.isZero (txMint unBalancedTx) then Nothing else Just (txMint unBalancedTx) - -- If the tx mints a token, then we find the missing lovelace considering the wallet's inputs. - -- Ex. If we mint token A, with no wallet inputs, then the missing lovelace is 'Ledger.minAdaTxOut'. - missingLovelaceForMintValue = - maybe 0 - (\mintValue -> max 0 (Ledger.minAdaTxOut - Ada.fromValue (mintValue <> fold ownInputValues))) - txMintMaybe - -- We add to the missing lovelace from the minting to the positive balance. - posWithMintAda = pos <> Ada.toValue missingLovelaceForMintValue - -- Now, we find the missing lovelace from the new positive balance. If - -- a token was minted, this should always be 0. But if no token was - -- minted, and if the positive balance is > 0 and < 'Ledger.minAdaTxOut', - -- then we adjust it to the minimum Ada. - missingLovelaceFromPosValue = - if valueIsZeroOrHasMinAda posWithMintAda +adjustBalanceWithMissingLovelace + :: (Value, Value) -- ^ The unbalanced tx's left and right balance. + -> (Value, Value) -- ^ New left and right balance. +adjustBalanceWithMissingLovelace (neg, pos) = do + + -- We find the missing lovelace from the new positive balance. If + -- the positive balance is > 0 and < 'Ledger.minAdaTxOut', + -- then we adjust it to the minimum Ada. + let missingLovelaceFromPosValue = + if valueIsZeroOrHasMinAda pos then 0 - else max 0 (Ledger.minAdaTxOut - Ada.fromValue posWithMintAda) + else max 0 (Ledger.minAdaTxOut - Ada.fromValue pos) -- We calculate the final negative and positive balances - newPos = pos <> Ada.toValue missingLovelaceForMintValue <> Ada.toValue missingLovelaceFromPosValue - newNeg = neg <> Ada.toValue missingLovelaceForMintValue <> Ada.toValue missingLovelaceFromPosValue + newPos = pos <> Ada.toValue missingLovelaceFromPosValue + newNeg = neg <> Ada.toValue missingLovelaceFromPosValue - pure (newNeg, newPos) + (newNeg, newPos) addOutput :: PaymentPubKey -> Maybe StakePubKey -> Value -> Tx -> Tx addOutput pk sk vl tx = tx & over Tx.outputs (pko :) where diff --git a/plutus-contract/test/Spec.hs b/plutus-contract/test/Spec.hs index 3e500bdc11..2f42a5a734 100644 --- a/plutus-contract/test/Spec.hs +++ b/plutus-contract/test/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main(main) where +import Spec.Balancing qualified import Spec.Contract qualified import Spec.Emulator qualified import Spec.ErrorChecking qualified @@ -25,5 +26,6 @@ tests = testGroup "plutus-contract" [ Spec.Secrets.tests, Spec.ErrorChecking.tests, Spec.Plutus.Contract.Wallet.tests, - Spec.Plutus.Contract.Oracle.tests + Spec.Plutus.Contract.Oracle.tests, + Spec.Balancing.tests ] diff --git a/plutus-contract/test/Spec/Balancing.hs b/plutus-contract/test/Spec/Balancing.hs new file mode 100644 index 0000000000..dc8ee1e4a4 --- /dev/null +++ b/plutus-contract/test/Spec/Balancing.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module Spec.Balancing(tests) where + +import Control.Lens hiding ((.>)) +import Control.Monad (void) +import Data.Map qualified as Map +import Data.Void (Void) +import Test.Tasty (TestTree, testGroup) + +import Ledger (Address, Validator, validatorHash) +import Ledger qualified +import Ledger.Ada qualified as Ada +import Ledger.Constraints qualified as Constraints +import Ledger.Scripts (mintingPolicyHash, unitDatum, unitRedeemer) +import Ledger.Typed.Scripts.MonetaryPolicies qualified as MPS +import Ledger.Value qualified as Value +import Plutus.Contract as Con +import Plutus.Contract.Test (assertAccumState, assertNoFailedTransactions, changeInitialWalletValue, checkPredicate, + checkPredicateOptions, defaultCheckOptions, w1, w2) +import Plutus.Trace qualified as Trace +import Plutus.V1.Ledger.Scripts (Datum (Datum)) +import PlutusTx qualified +import Prelude hiding (not) +import Wallet.Emulator qualified as EM + +tests :: TestTree +tests = + testGroup "balancing" + [ balanceTxnMinAda + , balanceTxnMinAda2 + , balanceTxnNoExtraOutput + ] + +balanceTxnMinAda :: TestTree +balanceTxnMinAda = + let ee = Value.singleton "ee" "ee" 1 + ff = Value.singleton "ff" "ff" 1 + options = defaultCheckOptions + & changeInitialWalletValue w1 (Value.scale 1000 (ee <> ff) <>) + vHash = validatorHash someValidator + + contract :: Contract () EmptySchema ContractError () + contract = do + let constraints1 = Constraints.mustPayToOtherScript vHash unitDatum (Value.scale 100 ff <> Ada.toValue Ledger.minAdaTxOut) + utx1 = either (error . show) id $ Constraints.mkTx @Void mempty constraints1 + submitTxConfirmed utx1 + utxo <- utxosAt someAddress + let txOutRef = head (Map.keys utxo) + constraints2 = Constraints.mustSpendScriptOutput txOutRef unitRedeemer + <> Constraints.mustPayToOtherScript vHash unitDatum (Value.scale 200 ee) + lookups2 = Constraints.unspentOutputs utxo <> Constraints.otherScript someValidator + utx2 = Constraints.adjustUnbalancedTx $ either (error . show) id $ Constraints.mkTx @Void lookups2 constraints2 + submitTxConfirmed utx2 + + trace = do + void $ Trace.activateContractWallet w1 contract + void $ Trace.waitNSlots 2 + + in checkPredicateOptions options "balancing doesn't create outputs with no Ada" assertNoFailedTransactions (void trace) + +balanceTxnMinAda2 :: TestTree +balanceTxnMinAda2 = + let vA n = Value.singleton "ee" "A" n + vB n = Value.singleton "ff" "B" n + mps = MPS.mkForwardingMintingPolicy vHash + vL n = Value.singleton (Value.mpsSymbol $ mintingPolicyHash mps) "L" n + options = defaultCheckOptions + & changeInitialWalletValue w1 (<> vA 1 <> vB 2) + vHash = validatorHash someValidator + payToWallet w = Constraints.mustPayToPubKey (EM.mockWalletPaymentPubKeyHash w) + mkTx lookups constraints = Constraints.adjustUnbalancedTx . either (error . show) id $ Constraints.mkTx @Void lookups constraints + + setupContract :: Contract () EmptySchema ContractError () + setupContract = do + -- Make sure there is a utxo with 1 A, 1 B, and 4 ada at w2 + submitTxConfirmed $ mkTx mempty (payToWallet w2 (vA 1 <> vB 1 <> Value.scale 2 (Ada.toValue Ledger.minAdaTxOut))) + -- Make sure there is a UTxO with 1 B and datum () at the script + submitTxConfirmed $ mkTx mempty (Constraints.mustPayToOtherScript vHash unitDatum (vB 1)) + -- utxo0 @ wallet2 = 1 A, 1 B, 4 Ada + -- utxo1 @ script = 1 B, 2 Ada + + wallet2Contract :: Contract () EmptySchema ContractError () + wallet2Contract = do + utxos <- utxosAt someAddress + let txOutRef = head (Map.keys utxos) + lookups = Constraints.unspentOutputs utxos + <> Constraints.otherScript someValidator + <> Constraints.mintingPolicy mps + constraints = Constraints.mustSpendScriptOutput txOutRef unitRedeemer -- spend utxo1 + <> Constraints.mustPayToOtherScript vHash unitDatum (vB 1) -- 2 ada and 1 B to script + <> Constraints.mustPayToOtherScript vHash (Datum $ PlutusTx.toBuiltinData (0 :: Integer)) (vB 1) -- 2 ada and 1 B to script (different datum) + <> Constraints.mustMintValue (vL 1) -- 1 L and 2 ada to wallet2 + submitTxConfirmed $ mkTx lookups constraints + + trace = do + void $ Trace.activateContractWallet w1 setupContract + void $ Trace.waitNSlots 10 + void $ Trace.activateContractWallet w2 wallet2Contract + void $ Trace.waitNSlots 10 + + in checkPredicateOptions options "balancing doesn't create outputs with no Ada (2)" assertNoFailedTransactions (void trace) + +balanceTxnNoExtraOutput :: TestTree +balanceTxnNoExtraOutput = + let vL n = Value.singleton (Ledger.scriptCurrencySymbol coinMintingPolicy) "coinToken" n + mkTx lookups constraints = either (error . show) id $ Constraints.mkTx @Void lookups constraints + + mintingOperation :: Contract [Int] EmptySchema ContractError () + mintingOperation = do + pkh <- Con.ownPaymentPubKeyHash + + let val = vL 200 + lookups = Constraints.mintingPolicy coinMintingPolicy + constraints = Constraints.mustMintValue val + <> Constraints.mustPayToPubKey pkh (val <> Ada.toValue Ledger.minAdaTxOut) + + tx <- submitUnbalancedTx $ mkTx lookups constraints + tell [length $ Ledger.getCardanoTxOutRefs tx] + + trace = do + void $ Trace.activateContract w1 mintingOperation "instance 1" + void $ Trace.waitNSlots 2 + tracePred = assertAccumState mintingOperation "instance 1" (== [2]) "has 2 outputs" + + in checkPredicate "balancing doesn't create extra output" tracePred (void trace) + +someAddress :: Address +someAddress = Ledger.scriptAddress someValidator + +someValidator :: Validator +someValidator = Ledger.mkValidatorScript $$(PlutusTx.compile [|| \(_ :: PlutusTx.BuiltinData) (_ :: PlutusTx.BuiltinData) (_ :: PlutusTx.BuiltinData) -> () ||]) + +{-# INLINABLE mkPolicy #-} +mkPolicy :: () -> Ledger.ScriptContext -> Bool +mkPolicy _ _ = True + +coinMintingPolicy :: Ledger.MintingPolicy +coinMintingPolicy = Ledger.mkMintingPolicyScript + $$(PlutusTx.compile [|| MPS.wrapMintingPolicy mkPolicy ||]) diff --git a/plutus-contract/test/Spec/Contract.hs b/plutus-contract/test/Spec/Contract.hs index 62b3d872e5..0ba1c4b1c6 100644 --- a/plutus-contract/test/Spec/Contract.hs +++ b/plutus-contract/test/Spec/Contract.hs @@ -25,21 +25,19 @@ import Data.Map qualified as Map import Data.Void (Void) import Test.Tasty (TestTree, testGroup) -import Ledger (Address, PaymentPubKeyHash, Validator, validatorHash) +import Ledger (Address, PaymentPubKeyHash, Validator) import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Constraints qualified as Constraints -import Ledger.Scripts (datumHash, mintingPolicyHash, unitDatum, unitRedeemer) +import Ledger.Scripts (datumHash) import Ledger.Tx (getCardanoTxId) -import Ledger.Typed.Scripts.MonetaryPolicies qualified as MPS -import Ledger.Value qualified as Value import Plutus.Contract as Con import Plutus.Contract.State qualified as State import Plutus.Contract.Test (Shrinking (DoShrink, DontShrink), TracePredicate, assertAccumState, assertContractError, assertDone, assertInstanceLog, assertNoFailedTransactions, assertResumableResult, - assertUserLog, changeInitialWalletValue, checkEmulatorFails, checkPredicateOptions, - defaultCheckOptions, endpointAvailable, minLogLevel, mockWalletPaymentPubKeyHash, not, w1, - w2, waitingForSlot, walletFundsChange, (.&&.)) + assertUserLog, checkEmulatorFails, checkPredicateOptions, defaultCheckOptions, + endpointAvailable, minLogLevel, mockWalletPaymentPubKeyHash, not, w1, w2, waitingForSlot, + walletFundsChange, (.&&.)) import Plutus.Contract.Types (ResumableResult (ResumableResult, _finalState), responses) import Plutus.Contract.Util (loopM) import Plutus.Trace qualified as Trace @@ -316,80 +314,8 @@ tests = in run "mustSatisfyAnyOf [mempty] works" ( assertDone c tag (const True) "should be done" ) (void $ activateContract w1 c tag) - - , balanceTxnMinAda - , balanceTxnMinAda2 ] -balanceTxnMinAda :: TestTree -balanceTxnMinAda = - let ee = Value.singleton "ee" "ee" 1 - ff = Value.singleton "ff" "ff" 1 - options = defaultCheckOptions - & changeInitialWalletValue w1 (Value.scale 1000 (ee <> ff) <>) - vHash = validatorHash someValidator - - contract :: Contract () EmptySchema ContractError () - contract = do - let constraints1 = Constraints.mustPayToOtherScript vHash unitDatum (Value.scale 100 ff <> Ada.toValue Ledger.minAdaTxOut) - utx1 = either (error . show) id $ Constraints.mkTx @Void mempty constraints1 - submitTxConfirmed utx1 - utxo <- utxosAt someAddress - let txOutRef = head (Map.keys utxo) - constraints2 = Constraints.mustSpendScriptOutput txOutRef unitRedeemer - <> Constraints.mustPayToOtherScript vHash unitDatum (Value.scale 200 ee) - lookups2 = Constraints.unspentOutputs utxo <> Constraints.otherScript someValidator - utx2 = Constraints.adjustUnbalancedTx $ either (error . show) id $ Constraints.mkTx @Void lookups2 constraints2 - submitTxConfirmed utx2 - - trace = do - Trace.activateContractWallet w1 contract - Trace.waitNSlots 2 - - in checkPredicateOptions options "balancing doesn't create outputs with no Ada" assertNoFailedTransactions (void trace) - -balanceTxnMinAda2 :: TestTree -balanceTxnMinAda2 = - let vA n = Value.singleton "ee" "A" n - vB n = Value.singleton "ff" "B" n - mps = MPS.mkForwardingMintingPolicy vHash - vL n = Value.singleton (Value.mpsSymbol $ mintingPolicyHash mps) "L" n - options = defaultCheckOptions - & changeInitialWalletValue w1 (<> vA 1 <> vB 2) - vHash = validatorHash someValidator - payToWallet w = Constraints.mustPayToPubKey (EM.mockWalletPaymentPubKeyHash w) - mkTx lookups constraints = Constraints.adjustUnbalancedTx . either (error . show) id $ Constraints.mkTx @Void lookups constraints - - setupContract :: Contract () EmptySchema ContractError () - setupContract = do - -- Make sure there is a utxo with 1 A, 1 B, and 4 ada at w2 - submitTxConfirmed $ mkTx mempty (payToWallet w2 (vA 1 <> vB 1 <> Value.scale 2 (Ada.toValue Ledger.minAdaTxOut))) - -- Make sure there is a UTxO with 1 B and datum () at the script - submitTxConfirmed $ mkTx mempty (Constraints.mustPayToOtherScript vHash unitDatum (vB 1)) - -- utxo0 @ wallet2 = 1 A, 1 B, 4 Ada - -- utxo1 @ script = 1 B, 2 Ada - - wallet2Contract :: Contract () EmptySchema ContractError () - wallet2Contract = do - utxos <- utxosAt someAddress - let txOutRef = head (Map.keys utxos) - lookups = Constraints.unspentOutputs utxos - <> Constraints.otherScript someValidator - <> Constraints.mintingPolicy mps - constraints = Constraints.mustSpendScriptOutput txOutRef unitRedeemer -- spend utxo1 - <> Constraints.mustPayToOtherScript vHash unitDatum (vB 1) -- 2 ada and 1 B to script - <> Constraints.mustPayToOtherScript vHash (Datum $ PlutusTx.toBuiltinData (0 :: Integer)) (vB 1) -- 2 ada and 1 B to script (different datum) - <> Constraints.mustMintValue (vL 1) -- 1 L and 2 ada to wallet2 - submitTxConfirmed $ mkTx lookups constraints - - trace = do - Trace.activateContractWallet w1 setupContract - Trace.waitNSlots 10 - Trace.activateContractWallet w2 wallet2Contract - Trace.waitNSlots 10 - - in checkPredicateOptions options "balancing doesn't create outputs with no Ada (2)" assertNoFailedTransactions (void trace) - checkpointContract :: Contract () Schema ContractError () checkpointContract = void $ do checkpoint $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure