From a64f10c7128f37e04bbc295e0979e240109a3b28 Mon Sep 17 00:00:00 2001 From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com> Date: Thu, 5 May 2022 12:03:10 +0100 Subject: [PATCH] finished first draft of treasury tests --- agora-test/Spec/Sample/Treasury.hs | 78 +++++++--- agora-test/Spec/Treasury.hs | 220 ++++++++++++++++++++--------- agora.cabal | 1 + agora/Agora/Treasury.hs | 8 +- 4 files changed, 219 insertions(+), 88 deletions(-) diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs index 09cf7f7..529c477 100644 --- a/agora-test/Spec/Sample/Treasury.hs +++ b/agora-test/Spec/Sample/Treasury.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wwarn #-} {- | Module: Spec.Sample.Treasury @@ -15,10 +14,14 @@ module Spec.Sample.Treasury ( validCtx, treasuryRef, gatTn, + walletIn, + trCredential, ) where import Agora.Effect.NoOp (noOpValidator) -import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator) +import Agora.Treasury ( + treasuryValidator, + ) import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) import Plutarch.Api.V1 (mkValidator, validatorHash) @@ -28,7 +31,11 @@ import Plutarch.DataRepr ( ) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutus.V1.Ledger.Address (Address (..)) -import Plutus.V1.Ledger.Api (BuiltinByteString) +import Plutus.V1.Ledger.Api ( + BuiltinByteString, + Credential (PubKeyCredential), + PubKeyHash (PubKeyHash), + ) import Plutus.V1.Ledger.Contexts ( ScriptContext (..), ScriptPurpose (Minting), @@ -39,8 +46,14 @@ import Plutus.V1.Ledger.Contexts ( ) import Plutus.V1.Ledger.Credential (Credential (ScriptCredential)) import Plutus.V1.Ledger.Interval qualified as Interval -import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (ValidatorHash)) -import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName)) +import Plutus.V1.Ledger.Scripts ( + Validator, + ValidatorHash (ValidatorHash), + ) +import Plutus.V1.Ledger.Value ( + CurrencySymbol, + TokenName (TokenName), + ) import Plutus.V1.Ledger.Value qualified as Value import PlutusTx qualified import Spec.Sample.Shared (signer) @@ -107,34 +120,64 @@ validCtx = } treasuryOut :: TxOut = TxOut - { txOutAddress = - Address - (ScriptCredential $ validatorHash trValidator) - Nothing + { txOutAddress = Address trCredential Nothing , txOutValue = Value.singleton "" "" 0 , txOutDatumHash = Just (toDatumHash ()) } +-- | Reference to treasury output. treasuryRef :: TxOutRef -treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1 +treasuryRef = + TxOutRef + "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + 1 +-- | Reference to dummy effect output. effectRef :: TxOutRef -effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0 +effectRef = + TxOutRef + "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" + 0 +-- | `ScriptCredential` used for the dummy treasury validator. +trCredential :: Credential +trCredential = ScriptCredential $ validatorHash trValidator + +-- | Mock effect script, used for testing. mockEffect :: Validator mockEffect = mkValidator $ noOpValidator gatCs +-- | The hash of the mock effect script. addressBs :: BuiltinByteString (ValidatorHash addressBs) = validatorHash mockEffect +-- | `TokenName` for GAT generated from address of `mockEffect`. gatTn :: TokenName gatTn = TokenName addressBs ------------------------------------------------------------------- +-- | Input representing a user wallet with a valid GAT. +walletIn :: TxInInfo +walletIn = + TxInInfo + { txInInfoOutRef = + TxOutRef + "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83" + 0 + , txInInfoResolved = + TxOut + { txOutDatumHash = Nothing + , txOutValue = Value.singleton gatCs gatTn 1 + , txOutAddress = + Address + (PubKeyCredential $ PubKeyHash addressBs) + Nothing + } + } --- Invalid treasury redeemer. - -data BadTreasuryRedeemer = NukeTheSystem +-- | Unsupported treasury redeemer. +data BadTreasuryRedeemer + = -- | Unsupported treasury redeemer. + NukeTheSystem Integer deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed @@ -142,8 +185,9 @@ PlutusTx.makeIsDataIndexed [ ('NukeTheSystem, 0) ] +-- | Plutarch implementation of `BadTreasuryRedeemer`. data PBadTreasuryRedeemer (s :: S) - = PNukeTheSystem (Term s (PDataRecord '[])) + = PNukeTheSystem (Term s (PDataRecord '["_0" ':= PInteger])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) @@ -160,5 +204,3 @@ deriving via ) instance (PConstantDecl BadTreasuryRedeemer) - ------------------------------------------------------------------- diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs index d431a96..96790f0 100644 --- a/agora-test/Spec/Treasury.hs +++ b/agora-test/Spec/Treasury.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE TemplateHaskell #-} {- | Module: Spec.Treasury @@ -7,6 +7,17 @@ Maintainer: jack@mlabs.city This module exports `tests`, a list of `TestTree`s, which ensure that Agora's treasury component works as desired. + +Tests need to fail when: + + 1. The reedeemer is of inproper form. TODO: Inquire. + 2. The script purpose is not minting. + 3. `singleAuthorityTokenBurned` returns false. + a. @n /= -1@ GATs burned. + b. An input returns 'False' for 'authorityTokensValidIn' + i. A wallet input has a GAT. + ii. A script has a GAT, the token name for which does /not/ + match the script's validator hash. -} module Spec.Treasury (tests) where @@ -14,89 +25,162 @@ import Agora.Treasury ( TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator, ) -import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) +import Plutus.V1.Ledger.Address (Address (Address)) +import Plutus.V1.Ledger.Api ( + BuiltinByteString, + DCert (DCertDelegRegKey), + ) import Plutus.V1.Ledger.Contexts ( ScriptContext (scriptContextPurpose, scriptContextTxInfo), - ScriptPurpose (Spending), - TxInfo (txInfoMint), + ScriptPurpose (Certifying, Rewarding, Spending), + TxInfo (txInfoInputs, txInfoMint), + txInInfoResolved, + txOutAddress, + ) +import Plutus.V1.Ledger.Credential ( + Credential (ScriptCredential), + StakingCredential (StakingHash), + ) +import Plutus.V1.Ledger.Scripts ( + ValidatorHash (ValidatorHash), ) import Plutus.V1.Ledger.Value qualified as Value -import PlutusTx qualified import Spec.Sample.Treasury ( BadTreasuryRedeemer (NukeTheSystem), gatCs, gatTn, + trCredential, treasuryRef, validCtx, + walletIn, ) import Spec.Util (validatorFailsWith, validatorSucceedsWith) import Test.Tasty (TestTree, testGroup) -{- - -`Spec.Util` provides a number of useful functions: - - - policySucceedsWith: checks that a minting policy succeeds. - - - policyFailsWith: checks that a minting policy fails. - - - validatorSucceedsWith: checks that validator succeeds. - - - validatorFailsWith: checks that validator fails. - - - scriptSucceeds: checks that an arbitrary script does not - `perror`. - - - scriptFails: checks that an arbitrary script `perror`s out. - --} - -{- - -Tests need to fail when: - - 1. The reedeemer is of inproper form. - 2. The script purpose is not minting. - 3. `singleAuthorityTokenBurned` returns false. - a. Multiple GATs burned. - b. An input returns 'False' for 'authorityTokensValidIn' - --} - tests :: [TestTree] tests = [ testGroup - "validator" - [ validatorSucceedsWith - "Allows for effect changes" - (treasuryValidator gatCs) - () - SpendTreasuryGAT - validCtx - , validatorFailsWith - "Fails with invalid redeemer" - (treasuryValidator gatCs) - () - (NukeTheSystem) - validCtx - , validatorFailsWith - "Fails with ScriptPurpose not Minting" - (treasuryValidator gatCs) - () - SpendTreasuryGAT - validCtx - { scriptContextPurpose = Spending treasuryRef - } - , validatorFailsWith - "Fails when multiple GATs burned" - (treasuryValidator gatCs) - () - SpendTreasuryGAT - validCtx - { scriptContextTxInfo = - validCtx.scriptContextTxInfo - { txInfoMint = Value.singleton gatCs gatTn (-2) - } - } + "Validator" + [ testGroup + "Positive" + [ validatorSucceedsWith + "Allows for effect changes" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + validCtx + ] + , testGroup + "Negative" + [ testGroup + "Fails with ScriptPurpose not Minting" + [ validatorFailsWith + "Spending" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + validCtx + { scriptContextPurpose = Spending treasuryRef + } + , validatorFailsWith + "Rewarding" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + validCtx + { scriptContextPurpose = + Rewarding $ + StakingHash trCredential + } + , validatorFailsWith + "Certifying" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + validCtx + { scriptContextPurpose = + Certifying $ + DCertDelegRegKey $ + StakingHash trCredential + } + ] + , -- , validatorFailsWith -- TODO: Check. + -- "Fails with invalid redeemer" + -- (treasuryValidator gatCs) + -- () + -- (NukeTheSystem 72) + -- validCtx + + validatorFailsWith -- TODO: Use QuickCheck. + "Fails when multiple GATs burned" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + validCtx + { scriptContextTxInfo = + validCtx.scriptContextTxInfo + { txInfoMint = + Value.singleton + gatCs + gatTn + (-2) + } + } + , validatorFailsWith + "Fails when GAT token name is not script address" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + ( let txInfo = validCtx.scriptContextTxInfo + inputs = txInfo.txInfoInputs + effectIn = inputs !! 1 + invalidEff = + effectIn + { txInInfoResolved = + effectIn.txInInfoResolved + { txOutAddress = + Address + ( ScriptCredential $ + ValidatorHash + wrongHash + ) + Nothing + } + } + in validCtx + { scriptContextTxInfo = + txInfo + { txInfoInputs = + [ inputs !! 0 + , invalidEff + ] + } + } + ) + , validatorFailsWith + "Fails with wallet as input" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + ( let txInfo = validCtx.scriptContextTxInfo + inputs = txInfo.txInfoInputs + newInputs = + [ inputs !! 0 + , walletIn + ] + in validCtx + { scriptContextTxInfo = + txInfo + { txInfoInputs = newInputs + } + } + ) + ] ] ] + +{- | A SHA-256 hash which (in all certainty) should not match the + hash of the dummy effect script. +-} +wrongHash :: BuiltinByteString +wrongHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b" diff --git a/agora.cabal b/agora.cabal index 4d90182..2cbc0a8 100644 --- a/agora.cabal +++ b/agora.cabal @@ -113,6 +113,7 @@ common test-deps build-depends: , apropos , apropos-tx + , lens , QuickCheck , quickcheck-instances , tasty diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 6e75c8e..1d113f9 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -60,8 +60,12 @@ deriving via instance PTryFrom PData (PAsData PTreasuryRedeemer) -instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer -deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer) +instance PUnsafeLiftDecl PTreasuryRedeemer where + type PLifted PTreasuryRedeemer = TreasuryRedeemer +deriving via + (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) + instance + (PConstantDecl TreasuryRedeemer) --------------------------------------------------------------------------------