From e91dcb7ce1dcbbb5cfec1440319143193b6c7bd5 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 22 Apr 2022 11:18:38 -0400 Subject: [PATCH] Now it checks specific treasury Emily's suggestion on the review --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 48 +++++++++++++++---- .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 2 +- agora-test/Spec/Util.hs | 2 +- agora/Agora/Effect/TreasuryWithdrawal.hs | 46 +++++++++--------- 4 files changed, 64 insertions(+), 34 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 09bf1dc..9df0310 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -7,16 +7,16 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawal (tests) where -import Spec.Sample.Effect.TreasuryWithdrawal ( - buildReceiversOutputFromDatum, - buildScriptContext, - currSymbol, - inputGAT, - inputTreasury, - outputTreasury, - outputUser, - users, - ) +import Spec.Sample.Effect.TreasuryWithdrawal + ( currSymbol, + users, + treasuries, + inputGAT, + inputTreasury, + outputTreasury, + outputUser, + buildReceiversOutputFromDatum, + buildScriptContext ) import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), @@ -102,6 +102,18 @@ tests = ] ++ drop 1 (buildReceiversOutputFromDatum datum2) ) + , effectFailsWith + "Unauthorized treasury" + (treasuryWithdrawalValidator currSymbol) + datum3 + ( buildScriptContext + [ inputGAT + , inputTreasury 999 (asset1 20) + ] + $ [ outputTreasury 999 (asset1 17) + ] + ++ buildReceiversOutputFromDatum datum3 + ) ] ] where @@ -112,10 +124,26 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) + ] $ + [ head treasuries + , treasuries !! 1 + , treasuries !! 2 ] datum2 = TreasuryWithdrawalDatum [ (head users, asset1 4 <> asset2 5) , (users !! 1, asset1 2 <> asset2 1) , (users !! 2, asset1 1) + ] $ + [ head treasuries + , treasuries !! 1 + , treasuries !! 2 ] + datum3 = + TreasuryWithdrawalDatum + [ (head users, asset1 1) + , (users !! 1, asset1 1) + , (users !! 2, asset1 1) + ] $ + [ treasuries !! 1 + ] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index c228dc5..6469953 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -112,7 +112,7 @@ outputUser indx val = } buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut] -buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs +buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs where f x = TxOut diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 069c7e3..df20043 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -156,7 +156,7 @@ effectFailsWith :: TestTree effectFailsWith tag eff datum scriptContext = validatorFailsWith tag eff datum () scriptContext - + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index d8a496a..5468112 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -38,7 +38,11 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified -newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} +data TreasuryWithdrawalDatum = + TreasuryWithdrawalDatum + { receivers :: [(Credential, Value)] + , treasuries :: [Credential] + } deriving stock (Show, GHC.Generic) deriving anyclass (Generic) @@ -50,7 +54,9 @@ newtype PTreasuryWithdrawalDatum (s :: S) ( Term s ( PDataRecord - '["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))] + '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) + , "treasuries" ':= PBuiltinList (PAsData PCredential) + ] ) ) deriving stock (GHC.Generic) @@ -83,17 +89,17 @@ deriving via treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do - receivers <- plet $ pfromData $ pfield @"receivers" # datum' + datum <- pletFields @'["receivers", "treasuries"] datum' txInfo <- pletFields @'["outputs", "inputs"] txInfo' PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' effInput <- pletFields @'["address", "value"] $ txOut let outputValues = pmap # plam - ( \(pfromData -> out') -> P.do - out <- pletFields @'["address", "value"] $ out' - cred <- pletFields @'["credential"] $ pfromData out.address - pdata $ ptuple # cred.credential # out.value + ( \(pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value ) # txInfo.outputs inputValues = @@ -101,23 +107,19 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ # plam ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do txOut <- pletFields @'["address", "value"] $ txOut' - pdata $ ptuple # txOut.address # txOut.value + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value ) # txInfo.inputs - treasuryInputValues <- plet $ - pfilter - # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address) - # inputValues - let treasuryCredentials = - pmap - # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData) - # treasuryInputValues - treasuryOutputValues = + treasuryInputValues <- + plet $ + pfilter + # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) + # inputValues + let treasuryOutputValues = pfilter # plam - ( \((pfield @"_0" #) . pfromData -> addr) -> P.do - pelem # addr # treasuryCredentials - ) + ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) # outputValues treasuryInputValuesSum = pfoldr @@ -133,10 +135,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ pfoldr # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) # pconstant (mempty :: Value) - # receivers + # datum.receivers outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) - #$ receivers + #$ datum.receivers excessShouldBePaidToInputs = pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum shouldNotPayToEffect =