diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index ca36558..709be31 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -1,4 +1,11 @@ -{-# OPTIONS_GHC -Wwarn #-} +{- | +Module: Main +Description: Agora test suite. +Maintainer: emi@haskell.fyi + +This module is the root of Agora's test suite. +-} +module Main (main) where -------------------------------------------------------------------------------- @@ -15,6 +22,7 @@ import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal import Spec.Model.MultiSig qualified as MultiSig import Spec.Proposal qualified as Proposal import Spec.Stake qualified as Stake +import Spec.Treasury qualified as Treasury -- | The Agora test suite. main :: IO () @@ -45,4 +53,7 @@ main = , testGroup "AuthorityToken tests" AuthorityToken.tests + , testGroup + "Treasury tests" + Treasury.tests ] diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs index c3ffbd6..09cf7f7 100644 --- a/agora-test/Spec/Sample/Treasury.hs +++ b/agora-test/Spec/Sample/Treasury.hs @@ -1 +1,164 @@ -module Spec.Sample.Treasury () where +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Module: Spec.Sample.Treasury +Description: Sample data for `Spec.Treasury`. +Maintainer: jack@mlabs.city + +This module contains sample data, used in the tests written in +`Spec.Treasury`. +-} +module Spec.Sample.Treasury ( + BadTreasuryRedeemer (NukeTheSystem), + gatCs, + validCtx, + treasuryRef, + gatTn, +) where + +import Agora.Effect.NoOp (noOpValidator) +import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator) +import GHC.Generics qualified as GHC +import Generics.SOP (Generic, I (I)) +import Plutarch.Api.V1 (mkValidator, validatorHash) +import Plutarch.DataRepr ( + DerivePConstantViaData (..), + PIsDataReprInstances (..), + ) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) +import Plutus.V1.Ledger.Address (Address (..)) +import Plutus.V1.Ledger.Api (BuiltinByteString) +import Plutus.V1.Ledger.Contexts ( + ScriptContext (..), + ScriptPurpose (Minting), + TxInInfo (..), + TxInfo (..), + TxOut (..), + TxOutRef (..), + ) +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.Value qualified as Value +import PlutusTx qualified +import Spec.Sample.Shared (signer) +import Spec.Util (datumPair, toDatumHash) + +{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol' + of a valid governance authority token (GAT). +-} +gatCs :: CurrencySymbol +gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + +trValidator :: Validator +trValidator = mkValidator (treasuryValidator gatCs) + +{- | A `ScriptContext` that should be compatible with treasury + transactions. +-} +validCtx :: ScriptContext +validCtx = + ScriptContext + { scriptContextPurpose = Minting gatCs + , scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ treasuryIn + , effectIn + ] + , txInfoOutputs = + [ treasuryOut + ] + , -- Ensure sufficient ADA for transaction costs. + txInfoFee = Value.singleton "" "" 2 -- 2 ADA. + , -- Burn the GAT. + txInfoMint = Value.singleton gatCs gatTn (-1) + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = + [ datumPair treasuryIn + , datumPair treasuryOut + , datumPair effectIn + ] + , txInfoId = + "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + } + } + where + treasuryIn = + TxInInfo + { txInInfoOutRef = treasuryRef + , txInInfoResolved = treasuryOut + } + effectIn = + TxInInfo + { txInInfoOutRef = effectRef + , txInInfoResolved = + TxOut + { txOutAddress = + Address (ScriptCredential $ validatorHash mockEffect) Nothing + , txOutValue = Value.singleton gatCs gatTn 1 + , txOutDatumHash = Just (toDatumHash ()) + } + } + treasuryOut :: TxOut = + TxOut + { txOutAddress = + Address + (ScriptCredential $ validatorHash trValidator) + Nothing + , txOutValue = Value.singleton "" "" 0 + , txOutDatumHash = Just (toDatumHash ()) + } + +treasuryRef :: TxOutRef +treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1 + +effectRef :: TxOutRef +effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0 + +mockEffect :: Validator +mockEffect = mkValidator $ noOpValidator gatCs + +addressBs :: BuiltinByteString +(ValidatorHash addressBs) = validatorHash mockEffect + +gatTn :: TokenName +gatTn = TokenName addressBs + +------------------------------------------------------------------ + +-- Invalid treasury redeemer. + +data BadTreasuryRedeemer = NukeTheSystem + deriving stock (Eq, Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed + ''BadTreasuryRedeemer + [ ('NukeTheSystem, 0) + ] + +data PBadTreasuryRedeemer (s :: S) + = PNukeTheSystem (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PBadTreasuryRedeemer + +instance PUnsafeLiftDecl PBadTreasuryRedeemer where + type PLifted PBadTreasuryRedeemer = BadTreasuryRedeemer +deriving via + ( DerivePConstantViaData + BadTreasuryRedeemer + PBadTreasuryRedeemer + ) + instance + (PConstantDecl BadTreasuryRedeemer) + +------------------------------------------------------------------ diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs index 2285b7b..d431a96 100644 --- a/agora-test/Spec/Treasury.hs +++ b/agora-test/Spec/Treasury.hs @@ -1,10 +1,102 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Module: Spec.Treasury +Description: Tests for Agora treasury. +Maintainer: jack@mlabs.city + +This module exports `tests`, a list of `TestTree`s, which ensure +that Agora's treasury component works as desired. +-} module Spec.Treasury (tests) where +import Agora.Treasury ( + TreasuryRedeemer (SpendTreasuryGAT), + treasuryValidator, + ) +import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) +import Plutus.V1.Ledger.Contexts ( + ScriptContext (scriptContextPurpose, scriptContextTxInfo), + ScriptPurpose (Spending), + TxInfo (txInfoMint), + ) +import Plutus.V1.Ledger.Value qualified as Value +import PlutusTx qualified +import Spec.Sample.Treasury ( + BadTreasuryRedeemer (NukeTheSystem), + gatCs, + gatTn, + treasuryRef, + validCtx, + ) +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 - "treasury" - [] + "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) + } + } + ] ] diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 365ad50..31347e1 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -3,7 +3,24 @@ Module : Spec.Util Maintainer : emi@haskell.fyi Description: Utility functions for testing Plutarch scripts with ScriptContext -Utility functions for testing Plutarch scripts with ScriptContext +Utility functions for testing Plutarch scripts with ScriptContext: + + - 'policySucceedsWith': checks that a minting policy succeeds. + + - 'policyFailsWith': checks that a minting policy fails. + + - 'validatorSucceedsWith': checks that validator succeeds. + + - 'validatorFailsWith': checks that validator fails. + + - 'effectSucceedsWith': checks that effect succeeds. + + - 'effectFailsWith': checks that effect fails. + + - 'scriptSucceeds': checks that an arbitrary script does not + `perror`. + + - 'scriptFails': checks that an arbitrary script `perror`s out. -} module Spec.Util ( -- * Testing utils @@ -131,7 +148,9 @@ validatorFailsWith tag validator datum redeemer scriptContext = # pconstant scriptContext ) --- | Check that a validator script succeeds, given a name and arguments. +{- | Check that a validator script succeeds, given a name and arguments. + TODO: Change docstring. +-} effectSucceedsWith :: ( PLift datum , PlutusTx.ToData (PLifted datum) @@ -143,7 +162,11 @@ effectSucceedsWith :: TestTree effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () --- | Check that a validator script fails, given a name and arguments. +-- TODO: Change docstring. + +{- | Check that a validator script fails, given a name and arguments. + TODO: Change docstring. +-} effectFailsWith :: ( PLift datum , PlutusTx.ToData (PLifted datum)