|
| 1 | +module Spec.TestContract.MintAndPay (zeroAdaOutTestContract) where |
| 2 | + |
| 3 | +import Data.Text (Text) |
| 4 | +import Ledger ( |
| 5 | + CurrencySymbol, |
| 6 | + PaymentPubKeyHash, |
| 7 | + ScriptContext, |
| 8 | + getCardanoTxId, |
| 9 | + ) |
| 10 | +import Ledger.Constraints qualified as Constraints |
| 11 | +import Ledger.Scripts qualified as Scripts |
| 12 | +import Ledger.Typed.Scripts (mkUntypedMintingPolicy) |
| 13 | +import Ledger.Typed.Scripts qualified as TypedScripts |
| 14 | +import Ledger.Value (tokenName) |
| 15 | +import Plutus.Contract (Contract, adjustUnbalancedTx, awaitTxConfirmed, mkTxConstraints, submitTxConfirmed, submitTxConstraintsWith) |
| 16 | + |
| 17 | +import Data.Void (Void) |
| 18 | +import Plutus.PAB.Effects.Contract.Builtin (EmptySchema) |
| 19 | +import Plutus.Script.Utils.V1.Scripts qualified as ScriptUtils |
| 20 | +import Plutus.V1.Ledger.Value qualified as Value |
| 21 | +import PlutusTx qualified |
| 22 | +import PlutusTx.Prelude qualified as PP |
| 23 | +import Prelude |
| 24 | + |
| 25 | +{- This test contract checks that outputs with 0 Ada are hadled properly. |
| 26 | + BPI does adjustment of ouptupt even w/o explicit `adjustUnbalancedTx`, |
| 27 | + so this test contract checks bot cases - with implicit and explicit adjustment. |
| 28 | +-} |
| 29 | +zeroAdaOutTestContract :: PaymentPubKeyHash -> Contract () EmptySchema Text () |
| 30 | +zeroAdaOutTestContract pkh = |
| 31 | + mintAndPayWithAdjustment 0 pkh |
| 32 | + >> mintAndPayNoAdjustment 0 pkh |
| 33 | + >> mintAndPayWithAdjustment 7 pkh |
| 34 | + >> mintAndPayNoAdjustment 7 pkh |
| 35 | + |
| 36 | +mintAndPayWithAdjustment :: Integer -> PaymentPubKeyHash -> Contract () EmptySchema Text () |
| 37 | +mintAndPayWithAdjustment tokensAmt pkh = do |
| 38 | + let token = Value.singleton currencySymbol (tokenName "ff") tokensAmt |
| 39 | + txc1 = |
| 40 | + Constraints.mustMintValueWithRedeemer Scripts.unitRedeemer token |
| 41 | + <> Constraints.mustPayToPubKey pkh token |
| 42 | + lookups1 = Constraints.plutusV1MintingPolicy mintingPolicy |
| 43 | + |
| 44 | + utx <- mkTxConstraints @Void lookups1 txc1 |
| 45 | + tx <- adjustUnbalancedTx utx |
| 46 | + submitTxConfirmed tx |
| 47 | + |
| 48 | +mintAndPayNoAdjustment :: Integer -> PaymentPubKeyHash -> Contract () EmptySchema Text () |
| 49 | +mintAndPayNoAdjustment tokensAmt pkh = do |
| 50 | + let token = Value.singleton currencySymbol (tokenName "ff") tokensAmt |
| 51 | + txc1 = |
| 52 | + Constraints.mustMintValueWithRedeemer Scripts.unitRedeemer token |
| 53 | + <> Constraints.mustPayToPubKey pkh token |
| 54 | + lookups1 = Constraints.plutusV1MintingPolicy mintingPolicy |
| 55 | + |
| 56 | + tx <- submitTxConstraintsWith @Void lookups1 txc1 |
| 57 | + awaitTxConfirmed (getCardanoTxId tx) |
| 58 | + |
| 59 | +-- minting policy |
| 60 | +{-# INLINEABLE mkPolicy #-} |
| 61 | +mkPolicy :: () -> ScriptContext -> Bool |
| 62 | +mkPolicy _ _ = |
| 63 | + PP.traceIfFalse "Mint only check" check |
| 64 | + where |
| 65 | + check = PP.length someWork PP.== 10 |
| 66 | + someWork = PP.sort [9, 8, 7, 6, 5, 4, 3, 2, 1, 0] :: [Integer] |
| 67 | + |
| 68 | +mintingPolicy :: TypedScripts.MintingPolicy |
| 69 | +mintingPolicy = |
| 70 | + Scripts.mkMintingPolicyScript |
| 71 | + $$(PlutusTx.compile [||mkUntypedMintingPolicy mkPolicy||]) |
| 72 | + |
| 73 | +currencySymbol :: CurrencySymbol |
| 74 | +currencySymbol = ScriptUtils.scriptCurrencySymbol mintingPolicy |
0 commit comments