Skip to content

Commit

Permalink
Merge pull request #137 from mlabs-haskell/bug-adjust-unbalanced
Browse files Browse the repository at this point in the history
Bugfix: adjusting unbalanced transaction
  • Loading branch information
mikekeke authored Oct 11, 2022
2 parents 1da1d04 + 7c0556d commit dc5c944
Show file tree
Hide file tree
Showing 5 changed files with 92 additions and 5 deletions.
8 changes: 4 additions & 4 deletions flake.lock

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion flake.nix
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
flake = false;
};
bot-plutus-interface.url =
"github:mlabs-haskell/bot-plutus-interface?ref=857ec745d50f7f0ebd5cd934110403fae301ef6f";
"github:mlabs-haskell/bot-plutus-interface?ref=d6cf1e3686bc31bb2571c6feefbe28e3a2c8bb06";
};

outputs =
Expand Down
1 change: 1 addition & 0 deletions plutip.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -188,6 +188,7 @@ test-suite plutip-tests
Spec.TestContract.AdjustTx
Spec.TestContract.AlwaysFail
Spec.TestContract.LockSpendMint
Spec.TestContract.MintAndPay
Spec.TestContract.SimpleContracts
Spec.TestContract.ValidateTimeRange

Expand Down
12 changes: 12 additions & 0 deletions test/Spec/Integration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ import Plutus.Contract qualified as Contract
import Spec.TestContract.AdjustTx (runAdjustTest)
import Spec.TestContract.AlwaysFail (lockThenFailToSpend)
import Spec.TestContract.LockSpendMint (lockThenSpend)
import Spec.TestContract.MintAndPay (zeroAdaOutTestContract)
import Spec.TestContract.SimpleContracts (
getUtxos,
getUtxosThrowsErr,
Expand Down Expand Up @@ -214,9 +215,20 @@ test =
]
, -- Test `adjustUnbalancedTx`
runAdjustTest
, testBugMintAndPay
]
++ testValueAssertionsOrderCorrectness

-- https://github.com/mlabs-haskell/plutip/issues/138
testBugMintAndPay :: (TestWallets, IO (ClusterEnv, NonEmpty BpiWallet) -> TestTree)
testBugMintAndPay =
assertExecution
"Adjustment of outputs with 0 Ada does not fail"
(withCollateral $ initAda [1000] <> initAda [1111])
(withContract $ \[p1] -> zeroAdaOutTestContract p1)
[ shouldSucceed
]

-- Tests for https://github.com/mlabs-haskell/plutip/issues/84
testValueAssertionsOrderCorrectness ::
[(TestWallets, IO (ClusterEnv, NonEmpty BpiWallet) -> TestTree)]
Expand Down
74 changes: 74 additions & 0 deletions test/Spec/TestContract/MintAndPay.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,74 @@
module Spec.TestContract.MintAndPay (zeroAdaOutTestContract) where

import Data.Text (Text)
import Ledger (
CurrencySymbol,
PaymentPubKeyHash,
ScriptContext,
getCardanoTxId,
)
import Ledger.Constraints qualified as Constraints
import Ledger.Scripts qualified as Scripts
import Ledger.Typed.Scripts (mkUntypedMintingPolicy)
import Ledger.Typed.Scripts qualified as TypedScripts
import Ledger.Value (tokenName)
import Plutus.Contract (Contract, adjustUnbalancedTx, awaitTxConfirmed, mkTxConstraints, submitTxConfirmed, submitTxConstraintsWith)

import Data.Void (Void)
import Plutus.PAB.Effects.Contract.Builtin (EmptySchema)
import Plutus.Script.Utils.V1.Scripts qualified as ScriptUtils
import Plutus.V1.Ledger.Value qualified as Value
import PlutusTx qualified
import PlutusTx.Prelude qualified as PP
import Prelude

{- This test contract checks that outputs with 0 Ada are hadled properly.
BPI does adjustment of ouptupt even w/o explicit `adjustUnbalancedTx`,
so this test contract checks bot cases - with implicit and explicit adjustment.
-}
zeroAdaOutTestContract :: PaymentPubKeyHash -> Contract () EmptySchema Text ()
zeroAdaOutTestContract pkh =
mintAndPayWithAdjustment 0 pkh
>> mintAndPayNoAdjustment 0 pkh
>> mintAndPayWithAdjustment 7 pkh
>> mintAndPayNoAdjustment 7 pkh

mintAndPayWithAdjustment :: Integer -> PaymentPubKeyHash -> Contract () EmptySchema Text ()
mintAndPayWithAdjustment tokensAmt pkh = do
let token = Value.singleton currencySymbol (tokenName "ff") tokensAmt
txc1 =
Constraints.mustMintValueWithRedeemer Scripts.unitRedeemer token
<> Constraints.mustPayToPubKey pkh token
lookups1 = Constraints.plutusV1MintingPolicy mintingPolicy

utx <- mkTxConstraints @Void lookups1 txc1
tx <- adjustUnbalancedTx utx
submitTxConfirmed tx

mintAndPayNoAdjustment :: Integer -> PaymentPubKeyHash -> Contract () EmptySchema Text ()
mintAndPayNoAdjustment tokensAmt pkh = do
let token = Value.singleton currencySymbol (tokenName "ff") tokensAmt
txc1 =
Constraints.mustMintValueWithRedeemer Scripts.unitRedeemer token
<> Constraints.mustPayToPubKey pkh token
lookups1 = Constraints.plutusV1MintingPolicy mintingPolicy

tx <- submitTxConstraintsWith @Void lookups1 txc1
awaitTxConfirmed (getCardanoTxId tx)

-- minting policy
{-# INLINEABLE mkPolicy #-}
mkPolicy :: () -> ScriptContext -> Bool
mkPolicy _ _ =
PP.traceIfFalse "Mint only check" check
where
check = PP.length someWork PP.== 10
someWork = PP.sort [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] :: [Integer]

mintingPolicy :: TypedScripts.MintingPolicy
mintingPolicy =
Scripts.mkMintingPolicyScript
$$(PlutusTx.compile [||mkUntypedMintingPolicy mkPolicy||])

currencySymbol :: CurrencySymbol
currencySymbol = ScriptUtils.scriptCurrencySymbol mintingPolicy

0 comments on commit dc5c944

Please sign in to comment.