diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 67ae244..7deb7da 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -14,6 +14,7 @@ import Spec.Sample.Effect.TreasuryWithdrawal ( inputGAT, inputTreasury, inputUser, + inputCollateral, outputTreasury, outputUser, treasuries, @@ -40,6 +41,7 @@ tests = datum1 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 10) ] $ outputTreasury 1 (asset1 7) : @@ -51,6 +53,7 @@ tests = datum1 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 10) , inputTreasury 2 (asset1 100) , inputTreasury 3 (asset1 500) @@ -67,6 +70,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -81,6 +85,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -96,6 +101,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -110,6 +116,7 @@ tests = datum3 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 999 (asset1 20) ] $ outputTreasury 999 (asset1 17) : @@ -122,6 +129,7 @@ tests = ( buildScriptContext [ inputGAT , inputTreasury 1 (asset1 20) + , inputTreasury 999 (asset1 20) , inputUser 99 (asset2 100) ] $ [ outputTreasury 1 (asset1 17) diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 37aa634..78e89e2 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -9,6 +9,7 @@ module Spec.Sample.Effect.TreasuryWithdrawal ( inputTreasury, inputUser, inputGAT, + inputCollateral, outputTreasury, outputUser, buildReceiversOutputFromDatum, @@ -106,6 +107,16 @@ inputUser indx val = , txOutDatumHash = Just (DatumHash "") } +inputCollateral :: Int -> TxInInfo +inputCollateral indx = + TxInInfo -- Initiator + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = Value.singleton "" "" 2000000 + , txOutDatumHash = Just (DatumHash "") + } + outputTreasury :: Int -> Value -> TxOut outputTreasury indx val = TxOut diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 3f980c4..ff9d3ec 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -20,12 +20,12 @@ import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) import Plutarch.Api.V1 ( - PCredential, - PTuple, - PValidator, - PValue, ptuple, - ) + PValidator, + PTuple, + PValue, + PCredential(..) + ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -34,7 +34,7 @@ import Plutarch.DataRepr ( ) import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Credential (Credential) +import Plutus.V1.Ledger.Credential ( Credential ) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified @@ -122,6 +122,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues receiverValuesSum = sumValues # datum.receivers + isCollateral = plam $ \cred -> P.do + pmatch cred $ \case + PPubKeyCredential _ -> pcon PTrue + PScriptCredential _ -> pcon PFalse -- Constraints outputContentMatchesRecivers = @@ -136,17 +140,18 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ effInput.address #== pfield @"address" # pfromData x ) # pfromData txInfo.outputs - inputsAreOnlyTreasuries = + inputsAreOnlyTreasuriesOrCollateral = pall # plam ( \((pfield @"_0" #) . pfromData -> cred) -> cred #== pfield @"credential" # effInput.address #|| pelem # cred # datum.treasuries + #|| isCollateral # pfromData cred ) # inputValues passert "Transaction should not pay to effects" shouldNotPayToEffect passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs - passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral popaque $ pconstant ()