diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 9df0310..67ae244 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -7,16 +7,18 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawal (tests) where -import Spec.Sample.Effect.TreasuryWithdrawal - ( currSymbol, - users, - treasuries, - inputGAT, - inputTreasury, - outputTreasury, - outputUser, - buildReceiversOutputFromDatum, - buildScriptContext ) +import Spec.Sample.Effect.TreasuryWithdrawal ( + buildReceiversOutputFromDatum, + buildScriptContext, + currSymbol, + inputGAT, + inputTreasury, + inputUser, + outputTreasury, + outputUser, + treasuries, + users, + ) import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), @@ -110,10 +112,23 @@ tests = [ inputGAT , inputTreasury 999 (asset1 20) ] - $ [ outputTreasury 999 (asset1 17) + $ outputTreasury 999 (asset1 17) : + buildReceiversOutputFromDatum datum3 + ) + , effectFailsWith + "Prevent transactions besides the withdrawal" + (treasuryWithdrawalValidator currSymbol) + datum3 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 20) + , inputUser 99 (asset2 100) + ] + $ [ outputTreasury 1 (asset1 17) + , outputUser 100 (asset2 100) ] ++ buildReceiversOutputFromDatum datum3 - ) + ) ] ] where @@ -124,17 +139,17 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) - ] $ - [ head treasuries - , treasuries !! 1 + ] + [ treasuries !! 1 , treasuries !! 2 + , treasuries !! 3 ] datum2 = TreasuryWithdrawalDatum [ (head users, asset1 4 <> asset2 5) , (users !! 1, asset1 2 <> asset2 1) , (users !! 2, asset1 1) - ] $ + ] [ head treasuries , treasuries !! 1 , treasuries !! 2 @@ -144,6 +159,5 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) - ] $ - [ treasuries !! 1 - ] + ] + [treasuries !! 1] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 6469953..37aa634 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -7,6 +7,7 @@ This module provides smaples for Treasury Withdrawal Effect tests. -} module Spec.Sample.Effect.TreasuryWithdrawal ( inputTreasury, + inputUser, inputGAT, outputTreasury, outputUser, @@ -77,7 +78,7 @@ treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show inputGAT :: TxInInfo inputGAT = - TxInInfo -- Initiator + TxInInfo (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing @@ -87,7 +88,7 @@ inputGAT = inputTreasury :: Int -> Value -> TxInInfo inputTreasury indx val = - TxInInfo -- Initiator + TxInInfo (TxOutRef "" 1) TxOut { txOutAddress = Address (treasuries !! indx) Nothing @@ -95,6 +96,16 @@ inputTreasury indx val = , txOutDatumHash = Just (DatumHash "") } +inputUser :: Int -> Value -> TxInInfo +inputUser indx val = + TxInInfo + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = val + , txOutDatumHash = Just (DatumHash "") + } + outputTreasury :: Int -> Value -> TxOut outputTreasury indx val = TxOut diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index df20043..f36b3ba 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -141,8 +141,7 @@ effectSucceedsWith :: PLifted datum -> ScriptContext -> TestTree -effectSucceedsWith tag eff datum scriptContext = - validatorSucceedsWith tag eff datum () scriptContext +effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () -- | Check that a validator script fails, given a name and arguments. effectFailsWith :: @@ -154,8 +153,7 @@ effectFailsWith :: PLifted datum -> ScriptContext -> TestTree -effectFailsWith tag eff datum scriptContext = - validatorFailsWith tag eff datum () scriptContext +effectFailsWith tag eff datum = validatorFailsWith tag eff datum () -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 5468112..29a269d 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -38,11 +38,10 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified -data TreasuryWithdrawalDatum = - TreasuryWithdrawalDatum - { receivers :: [(Credential, Value)] - , treasuries :: [Credential] - } +data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum + { receivers :: [(Credential, Value)] + , treasuries :: [Credential] + } deriving stock (Show, GHC.Generic) deriving anyclass (Generic) @@ -119,23 +118,15 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ let treasuryOutputValues = pfilter # plam - ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) + (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) # outputValues - treasuryInputValuesSum = + sumValues = pfoldr # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) # pconstant (mempty :: Value) - # treasuryInputValues - treasuryOutputValuesSum = - pfoldr - # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) - # pconstant (mempty :: Value) - # treasuryOutputValues - receiverValuesSum = - pfoldr - # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) - # pconstant (mempty :: Value) - # datum.receivers + treasuryInputValuesSum = sumValues # treasuryInputValues + treasuryOutputValuesSum = sumValues # treasuryOutputValues + receiverValuesSum = sumValues # datum.receivers outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ datum.receivers @@ -148,8 +139,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ effInput.address #== pfield @"address" # pfromData x ) # pfromData txInfo.outputs + inputsAreOnlyTreasuries = + pall + # plam + ( \((pfield @"_0" #) . pfromData -> cred) -> + cred #== pfield @"credential" # effInput.address + #|| pelem # cred # datum.treasuries + ) + # inputValues passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Transaction should not pay to effects" shouldNotPayToEffect + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs popaque $ pconstant ()