diff --git a/Makefile b/Makefile index 9696c09..974d8ed 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that. SHELL := /bin/sh -.PHONY: hoogle format haddock usage format_nix format_haskell format_check +.PHONY: hoogle format haddock usage format_nix format_haskell format_check lint usage: @echo "usage: make [OPTIONS]" @@ -14,6 +14,7 @@ usage: @echo " format_haskell -- Format haskell stuff, including source code and cabal files" @echo " format_nix -- Format *.nix files only" @echo " format_check -- Check if all haskell stuff have been formatted correctly" + @echo " lint -- Get hlint suggestions for project" hoogle: pkill hoogle || true @@ -43,3 +44,5 @@ haddock: tag: hasktags -x agora agora-bench agora-test +lint: + hlint agora agora-bench agora-test diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 31e75b9..47e50f8 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - import Prelude -------------------------------------------------------------------------------- @@ -14,6 +12,7 @@ import Spec.Governor qualified as Governor 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 () @@ -33,6 +32,18 @@ main = , testGroup "Proposal tests" Proposal.tests + , testGroup + "AuthorityToken tests" + AuthorityToken.tests + , testGroup + "Treasury tests" + Treasury.tests + , testGroup + "AuthorityToken tests" + AuthorityToken.tests + , testGroup + "Governor tests" + Governor.tests , testGroup "Multisig tests" [ testGroup @@ -41,10 +52,4 @@ main = , MultiSig.genTests ] ] - , testGroup - "AuthorityToken tests" - AuthorityToken.tests - , testGroup - "Governor tests" - Governor.tests ] diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs index 1764d56..96f50b9 100644 --- a/agora-test/Spec/Sample/Shared.hs +++ b/agora-test/Spec/Sample/Shared.hs @@ -40,8 +40,17 @@ module Spec.Sample.Shared ( -- ** Authority authorityToken, authorityTokenSymbol, + + -- ** Treasury + treasuryOut, + gatTn, + gatCs, + mockTrEffect, + trCredential, + wrongEffHash, ) where +import Agora.Effect.NoOp (noOpValidator) import Agora.AuthorityToken import Agora.Governor ( Governor (Governor), @@ -66,10 +75,13 @@ import Agora.Proposal ( ProposalThresholds (..), ) import Agora.Stake (Stake (..)) +import Agora.Treasury (treasuryValidator) +import Agora.Utils (validatorHashToTokenName) import Plutarch.Api.V1 ( mintingPolicySymbol, mkMintingPolicy, mkValidator, + validatorHash ) import Plutarch.SafeMoney import Plutus.V1.Ledger.Address (scriptHashAddress) @@ -82,8 +94,11 @@ import Plutus.V1.Ledger.Api ( TxOutRef (TxOutRef), Value, ) -import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash) -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.V1.Ledger.Contexts ( + TxOut (..), + ) +import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..)) +import Plutus.V1.Ledger.Value (TokenName, AssetClass) import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- @@ -163,11 +178,52 @@ defaultProposalThresholds = , startVoting = Tagged 10 } -minAda :: Value -minAda = Value.singleton "" "" 10_000_000 - authorityToken :: AuthorityToken authorityToken = authorityTokenFromGovernor governor authorityTokenSymbol :: CurrencySymbol authorityTokenSymbol = authorityTokenSymbolFromGovernor governor + +------------------------------------------------------------------ + +treasuryOut :: TxOut +treasuryOut = + TxOut + { txOutAddress = Address trCredential Nothing + , txOutValue = minAda + , txOutDatumHash = Nothing + } + +{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol' + of a valid governance authority token (GAT). +-} +gatCs :: CurrencySymbol +gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + +trValidator :: Validator +trValidator = mkValidator (treasuryValidator gatCs) + +-- | `ScriptCredential` used for the dummy treasury validator. +trCredential :: Credential +trCredential = ScriptCredential $ validatorHash trValidator + +-- | `TokenName` for GAT generated from address of `mockTrEffect`. +gatTn :: TokenName +gatTn = validatorHashToTokenName $ validatorHash mockTrEffect + +-- | Mock treasury effect script, used for testing. +mockTrEffect :: Validator +mockTrEffect = mkValidator $ noOpValidator gatCs + +{- | A SHA-256 hash which (in all certainty) should not match the + hash of the dummy effect script. +-} +wrongEffHash :: ValidatorHash +wrongEffHash = + ValidatorHash + "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b" + +------------------------------------------------------------------ + +minAda :: Value +minAda = Value.singleton "" "" 10_000_000 diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs new file mode 100644 index 0000000..1cfb02c --- /dev/null +++ b/agora-test/Spec/Sample/Treasury.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +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 ( + gatCs, + validCtx, + treasuryRef, + gatTn, + walletIn, + trCtxGATNameNotAddress, +) where + +import Plutarch.Api.V1 (validatorHash) +import Plutus.V1.Ledger.Address (Address (..)) +import Plutus.V1.Ledger.Api ( + BuiltinByteString, + Credential (PubKeyCredential), + PubKeyHash (PubKeyHash), + ) +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 ( + ValidatorHash (ValidatorHash), + ) +import Plutus.V1.Ledger.Value qualified as Value +import Spec.Sample.Shared ( + gatCs, + gatTn, + minAda, + mockTrEffect, + signer, + treasuryOut, + wrongEffHash, + ) +import Spec.Util (datumPair) + +{- | 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 mockTrEffect) Nothing + , txOutValue = + mconcat + [ Value.singleton gatCs gatTn 1 + , minAda + ] + , txOutDatumHash = Nothing + } + } + +-- | Reference to treasury output. +treasuryRef :: TxOutRef +treasuryRef = + TxOutRef + "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + 1 + +-- | Reference to dummy effect output. +effectRef :: TxOutRef +effectRef = + TxOutRef + "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" + 0 + +-- | 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 + } + } + +addressBs :: BuiltinByteString +(ValidatorHash addressBs) = validatorHash mockTrEffect + +trCtxGATNameNotAddress :: ScriptContext +trCtxGATNameNotAddress = + let txInfo = validCtx.scriptContextTxInfo + inputs = txInfo.txInfoInputs + effectIn = inputs !! 1 + invalidEff = + effectIn + { txInInfoResolved = + effectIn.txInInfoResolved + { txOutAddress = Address (ScriptCredential wrongEffHash) Nothing + } + } + in validCtx + { scriptContextTxInfo = + txInfo + { txInfoInputs = + [ head inputs + , invalidEff + ] + } + } diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs new file mode 100644 index 0000000..dd1044a --- /dev/null +++ b/agora-test/Spec/Treasury.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +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. + +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 + +import Agora.Treasury ( + TreasuryRedeemer (SpendTreasuryGAT), + treasuryValidator, + ) +import Plutus.V1.Ledger.Api ( + DCert (DCertDelegRegKey), + ) +import Plutus.V1.Ledger.Contexts ( + ScriptContext (scriptContextPurpose, scriptContextTxInfo), + ScriptPurpose (Certifying, Rewarding, Spending), + TxInfo (txInfoInputs, txInfoMint), + ) +import Plutus.V1.Ledger.Credential ( + StakingCredential (StakingHash), + ) +import Plutus.V1.Ledger.Value qualified as Value +import Spec.Sample.Shared ( + trCredential, + ) +import Spec.Sample.Treasury ( + gatCs, + gatTn, + trCtxGATNameNotAddress, + treasuryRef, + validCtx, + walletIn, + ) +import Spec.Util (validatorFailsWith, validatorSucceedsWith) +import Test.Tasty (TestTree, testGroup) + +tests :: [TestTree] +tests = + [ testGroup + "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: 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 + trCtxGATNameNotAddress + , validatorFailsWith + "Fails with wallet as input" + (treasuryValidator gatCs) + () + SpendTreasuryGAT + ( let txInfo = validCtx.scriptContextTxInfo + inputs = txInfo.txInfoInputs + newInputs = + [ head inputs + , walletIn + ] + in validCtx + { scriptContextTxInfo = + txInfo + { txInfoInputs = newInputs + } + } + ) + ] + ] + ] 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) diff --git a/agora.cabal b/agora.cabal index cb2ca3a..1a74a30 100644 --- a/agora.cabal +++ b/agora.cabal @@ -111,6 +111,7 @@ common deps common test-deps build-depends: + , agora , apropos , apropos-tx , QuickCheck @@ -137,11 +138,10 @@ library Agora.Stake Agora.Stake.Scripts Agora.Treasury - - other-modules: Agora.Utils Agora.Utils.Value + other-modules: hs-source-dirs: agora library pprelude @@ -169,7 +169,9 @@ test-suite agora-test Spec.Sample.Proposal Spec.Sample.Shared Spec.Sample.Stake + Spec.Sample.Treasury Spec.Stake + Spec.Treasury Spec.Util build-depends: agora diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 38f45f4..480d42d 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -2,7 +2,6 @@ Module : Agora.AuthorityToken Maintainer : emi@haskell.fyi Description: Tokens acting as redeemable proofs of DAO authority. - Tokens acting as redeemable proofs of DAO authority. -} module Agora.AuthorityToken ( @@ -63,7 +62,6 @@ newtype AuthorityToken = AuthorityToken the script address the token resides in matches the TokenName. Since the TokenName was tagged upon mint with the Effect script it was sent to, this is enough to prove validity. - In other words, check that all assets of a particular currency symbol are tagged with a TokenName that matches where they live. -} diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index f3ff441..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) -------------------------------------------------------------------------------- @@ -91,6 +95,7 @@ treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do gatCs <- plet $ pconstant gatCs' - passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint + passert "A single authority token has been burned" $ + singleAuthorityTokenBurned gatCs txInfo' mint popaque $ pconstant ()