diff --git a/agora-bench/Bench.hs b/agora-bench/Bench.hs index 0539f24..53a7cab 100644 --- a/agora-bench/Bench.hs +++ b/agora-bench/Bench.hs @@ -1,12 +1,29 @@ -module Bench (Benchmark (..), benchmarkSize) where +{-# LANGUAGE RecordWildCards #-} + +module Bench (Benchmark (..), benchmarkScript, specificationTreeToBenchmarks) where import Codec.Serialise (serialise) import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Short qualified as SBS -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text (Text) -import Plutus.V1.Ledger.Scripts qualified as Plutus +import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=)) +import Data.List (intercalate) +import Data.Maybe (fromJust) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.V1.Ledger.Api ( + ExBudget (ExBudget), + ExCPU (..), + ExMemory (..), + Script, + ) +import Plutus.V1.Ledger.Api qualified as Plutus +import Prettyprinter (Pretty (pretty), indent, vsep) + +import Spec.Specification ( + Specification (Specification), + SpecificationExpectation (Success), + SpecificationTree (..), + ) -------------------------------------------------------------------------------- @@ -14,20 +31,59 @@ import Plutus.V1.Ledger.Scripts qualified as Plutus data Benchmark = Benchmark { name :: Text -- ^ Human readable name describing script. - , size :: Int + , cpuBudget :: ExCPU + -- ^ The on-chain execution cost of a script. + , memoryBudget :: ExMemory + -- ^ The on-chain memory budget of a script. + , scriptSize :: Int -- ^ The on-chain size of a script. } - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) --- | Create a benchmark containing only the size of the script. -benchmarkSize :: Text -> Plutus.Script -> Set Benchmark -benchmarkSize name script = - Set.singleton $ - Benchmark - { name = name - , size = scriptSize script - } +instance Pretty Benchmark where + pretty (Benchmark name (ExCPU (toInteger -> cpu)) (ExMemory (toInteger -> mem)) size) = + vsep + [ pretty name + , indent 4 $ + vsep + [ "CPU: " <> pretty cpu + , "MEM: " <> pretty mem + , "SIZE: " <> pretty size + ] + ] --- | Compute the size of a script on-chain. -scriptSize :: Plutus.Script -> Int -scriptSize = SBS.length . SBS.toShort . LBS.toStrict . serialise +instance ToNamedRecord Benchmark where + toNamedRecord (Benchmark {..}) = + namedRecord + [ "name" .= name + , "cpu" .= cpuBudget + , "mem" .= memoryBudget + , "size" .= scriptSize + ] + +instance DefaultOrdered Benchmark where + headerOrder _ = header ["name", "cpu", "mem", "size"] + +benchmarkScript :: String -> Script -> Benchmark +benchmarkScript name script = Benchmark (pack name) cpu mem size + where + (ExBudget cpu mem) = evalScriptCounting . serialiseScriptShort $ script + size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script + + serialiseScriptShort :: Script -> SBS.ShortByteString + serialiseScriptShort = SBS.toShort . LBS.toStrict . serialise -- Using `flat` here breaks `evalScriptCounting` + evalScriptCounting :: Plutus.SerializedScript -> Plutus.ExBudget + evalScriptCounting script = + let costModel = fromJust Plutus.defaultCostModelParams + (_logout, e) = Plutus.evaluateScriptCounting Plutus.Verbose costModel script [] + in case e of + Left evalError -> error ("Eval Error: " <> show evalError) + Right exbudget -> exbudget + +specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark] +specificationTreeToBenchmarks = go [] + where + go names (Terminal ((Specification n ex s))) = case ex of + Success -> [benchmarkScript (intercalate "/" (names <> [n])) s] + _ -> [] + go names (Group gn tree) = mconcat $ go (names <> [gn]) <$> tree diff --git a/agora-bench/Main.hs b/agora-bench/Main.hs index 95307ca..f15e73f 100644 --- a/agora-bench/Main.hs +++ b/agora-bench/Main.hs @@ -1,42 +1,43 @@ module Main (main) where -import Agora.AuthorityToken (authorityTokenPolicy) -import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator) -import Agora.Governor (Governor (..)) -import Agora.Governor.Scripts (governorPolicy, governorValidator) -import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) -import Agora.Stake.Scripts (stakePolicy, stakeValidator) -import Agora.Treasury (treasuryValidator) -import Bench -import Data.Foldable (for_) -import Plutus.V1.Ledger.Api (CurrencySymbol) -import Sample.Shared +import Bench (specificationTreeToBenchmarks) +import Data.Csv (encodeDefaultOrderedByName) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Text.Lazy.IO as I (writeFile) +import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty) +import Prettyprinter.Render.String (renderString) +import Spec.AuthorityToken qualified as AuthorityToken +import Spec.Effect.GovernorMutation qualified as GovernorMutation +import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal +import Spec.Governor qualified as Governor +import Spec.Proposal qualified as Proposal +import Spec.Specification (group) +import Spec.Stake qualified as Stake +import Spec.Treasury qualified as Treasury import Prelude -------------------------------------------------------------------------------- main :: IO () main = do - let benchmarks = - mconcat - [ -- GATs - benchmarkSize "authorityTokenPolicy" $ compile $ authorityTokenPolicy authorityToken - , -- Governor - benchmarkSize "governorValidator" $ compile $ governorValidator governor - , benchmarkSize "governorPolicy" $ compile $ governorPolicy governor - , -- Stake - benchmarkSize "stakeValidator" $ compile $ stakeValidator stake - , benchmarkSize "stakePolicy" $ compile $ stakePolicy governor.gtClassRef - , -- Proposal - benchmarkSize "proposalValidator" $ compile $ proposalValidator proposal - , benchmarkSize "proposalPolicy" $ compile $ proposalPolicy govAssetClass - , -- Treasury - benchmarkSize "treasuryValidator" $ compile $ treasuryValidator gatCS - , -- Effect validators - benchmarkSize "treasuryWithdrawalValidator" $ compile $ treasuryWithdrawalValidator gatCS + I.writeFile "bench.csv" $ + (decodeUtf8 . encodeDefaultOrderedByName) res + + mapM_ (putStrLn . renderString . layoutPretty defaultLayoutOptions . pretty) res + where + res = + specificationTreeToBenchmarks $ + group + "Agora" + [ group + "Effects" + [ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs + , group "Governor Mutation Effect" GovernorMutation.specs + ] + , group "Stake" Stake.specs + , group "Proposal" Proposal.specs + , group "AuthorityToken" AuthorityToken.specs + , group "Treasury" Treasury.specs + , group "AuthorityToken" AuthorityToken.specs + , group "Governor" Governor.specs ] - - for_ benchmarks print - -gatCS :: CurrencySymbol -gatCS = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" -- arbitrary CS diff --git a/agora-test/Spec/AuthorityToken.hs b/agora-spec/Spec/AuthorityToken.hs similarity index 96% rename from agora-test/Spec/AuthorityToken.hs rename to agora-spec/Spec/AuthorityToken.hs index fdfda03..2c28b96 100644 --- a/agora-test/Spec/AuthorityToken.hs +++ b/agora-spec/Spec/AuthorityToken.hs @@ -7,13 +7,12 @@ Description: Tests for Authority token functions Tests for Authority token functions -} -module Spec.AuthorityToken (tests) where +module Spec.AuthorityToken (specs) where -------------------------------------------------------------------------------- import Agora.AuthorityToken (singleAuthorityTokenBurned) import Plutarch -import Test.Tasty (TestTree, testGroup) import Prelude -------------------------------------------------------------------------------- @@ -33,7 +32,12 @@ import Plutus.V1.Ledger.Api ( import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value import PlutusTx.AssocMap qualified as AssocMap -import Test.Util (scriptFails, scriptSucceeds) +import Spec.Specification ( + SpecificationTree, + group, + scriptFails, + scriptSucceeds, + ) currencySymbol :: CurrencySymbol currencySymbol = "deadbeef" @@ -65,10 +69,10 @@ singleAuthorityTokenBurnedTest mint outs = perror in compile s -tests :: [TestTree] -tests = +specs :: [SpecificationTree] +specs = [ -- This is better suited for plutarch-test - testGroup + group "singleAuthorityTokenBurned" [ scriptSucceeds "Correct simple" diff --git a/agora-test/Spec/Effect/GovernorMutation.hs b/agora-spec/Spec/Effect/GovernorMutation.hs similarity index 88% rename from agora-test/Spec/Effect/GovernorMutation.hs rename to agora-spec/Spec/Effect/GovernorMutation.hs index 18ed995..d38d382 100644 --- a/agora-test/Spec/Effect/GovernorMutation.hs +++ b/agora-spec/Spec/Effect/GovernorMutation.hs @@ -1,4 +1,4 @@ -module Spec.Effect.GovernorMutation (tests) where +module Spec.Effect.GovernorMutation (specs) where import Agora.Effect.GovernorMutation (mutateGovernorValidator) import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) @@ -15,14 +15,20 @@ import Sample.Effect.GovernorMutation ( validNewGovernorDatum, ) import Sample.Shared qualified as Shared -import Test.Tasty (TestTree, testGroup) -import Test.Util (effectFailsWith, effectSucceedsWith, validatorFailsWith, validatorSucceedsWith) +import Spec.Specification ( + SpecificationTree, + effectFailsWith, + effectSucceedsWith, + group, + validatorFailsWith, + validatorSucceedsWith, + ) -tests :: [TestTree] -tests = - [ testGroup +specs :: [SpecificationTree] +specs = + [ group "validator" - [ testGroup + [ group "valid new governor datum" [ validatorSucceedsWith "governor validator should pass" @@ -44,7 +50,7 @@ tests = (mkEffectDatum validNewGovernorDatum) (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef)) ] - , testGroup + , group "invalid new governor datum" [ validatorFailsWith "governor validator should fail" diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-spec/Spec/Effect/TreasuryWithdrawal.hs similarity index 95% rename from agora-test/Spec/Effect/TreasuryWithdrawal.hs rename to agora-spec/Spec/Effect/TreasuryWithdrawal.hs index a380edb..f46808d 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-spec/Spec/Effect/TreasuryWithdrawal.hs @@ -3,9 +3,9 @@ Module : Spec.Effect.TreasuryWithdrawalEffect Maintainer : seungheon.ooh@gmail.com Description: Sample based testing for Treasury Withdrawal Effect -This module tests the Treasury Withdrawal Effect. +This module specs the Treasury Withdrawal Effect. -} -module Spec.Effect.TreasuryWithdrawal (tests) where +module Spec.Effect.TreasuryWithdrawal (specs) where import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), @@ -25,12 +25,16 @@ import Sample.Effect.TreasuryWithdrawal ( treasuries, users, ) -import Test.Tasty (TestTree, testGroup) -import Test.Util (effectFailsWith, effectSucceedsWith) +import Spec.Specification ( + SpecificationTree, + effectFailsWith, + effectSucceedsWith, + group, + ) -tests :: [TestTree] -tests = - [ testGroup +specs :: [SpecificationTree] +specs = + [ group "effect" [ effectSucceedsWith "Simple" diff --git a/agora-test/Spec/Governor.hs b/agora-spec/Spec/Governor.hs similarity index 87% rename from agora-test/Spec/Governor.hs rename to agora-spec/Spec/Governor.hs index 3ac39a2..214b4d3 100644 --- a/agora-test/Spec/Governor.hs +++ b/agora-spec/Spec/Governor.hs @@ -3,7 +3,7 @@ Module : Spec.Governor Maintainer : connor@mlabs.city Description: Tests for Agora governor. -Thie module exports `tests`, a list of `TestTree`s, which ensure +Thie module exports `specs`, a list of `TestTree`s, which ensure that Agora's governor component workds as intended. Tests should pass when the validator or policy is given one of the @@ -11,7 +11,7 @@ valid script contexts, which are defined in 'Agora.Sample.Governor'. TODO: Add negative test cases, see [#76](https://github.com/Liqwid-Labs/agora/issues/76). -} -module Spec.Governor (tests) where +module Spec.Governor (specs) where import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..)) import Agora.Governor.Scripts (governorPolicy, governorValidator) @@ -19,14 +19,18 @@ import Agora.Proposal (ProposalId (..)) import Data.Default.Class (Default (def)) import Sample.Governor (createProposal, mintGATs, mintGST, mutateState) import Sample.Shared qualified as Shared -import Test.Tasty (TestTree, testGroup) -import Test.Util (policySucceedsWith, validatorSucceedsWith) +import Spec.Specification ( + SpecificationTree, + group, + policySucceedsWith, + validatorSucceedsWith, + ) -------------------------------------------------------------------------------- -tests :: [TestTree] -tests = - [ testGroup +specs :: [SpecificationTree] +specs = + [ group "policy" [ policySucceedsWith "GST minting" @@ -34,7 +38,7 @@ tests = () mintGST ] - , testGroup + , group "validator" [ validatorSucceedsWith "proposal creation" diff --git a/agora-test/Spec/Model/MultiSig.hs b/agora-spec/Spec/Model/MultiSig.hs similarity index 100% rename from agora-test/Spec/Model/MultiSig.hs rename to agora-spec/Spec/Model/MultiSig.hs diff --git a/agora-test/Spec/Proposal.hs b/agora-spec/Spec/Proposal.hs similarity index 95% rename from agora-test/Spec/Proposal.hs rename to agora-spec/Spec/Proposal.hs index c381126..d4c6426 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-spec/Spec/Proposal.hs @@ -7,7 +7,7 @@ Description: Tests for Proposal policy and validator Tests for Proposal policy and validator -} -module Spec.Proposal (tests) where +module Spec.Proposal (specs) where -------------------------------------------------------------------------------- @@ -45,15 +45,19 @@ import PlutusTx.AssocMap qualified as AssocMap import Sample.Proposal qualified as Proposal import Sample.Shared (signer, signer2) import Sample.Shared qualified as Shared -import Test.Tasty (TestTree, testGroup) -import Test.Util (policySucceedsWith, validatorSucceedsWith) +import Spec.Specification ( + SpecificationTree, + group, + policySucceedsWith, + validatorSucceedsWith, + ) -------------------------------------------------------------------------------- --- | Stake tests. -tests :: [TestTree] -tests = - [ testGroup +-- | Stake specs. +specs :: [SpecificationTree] +specs = + [ group "policy" [ policySucceedsWith "proposalCreation" @@ -61,9 +65,9 @@ tests = () Proposal.proposalCreation ] - , testGroup + , group "validator" - [ testGroup + [ group "cosignature" [ validatorSucceedsWith "proposal" @@ -97,7 +101,7 @@ tests = WitnessStake (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef)) ] - , testGroup + , group "voting" [ validatorSucceedsWith "proposal" diff --git a/agora-spec/Spec/Specification.hs b/agora-spec/Spec/Specification.hs new file mode 100644 index 0000000..2063260 --- /dev/null +++ b/agora-spec/Spec/Specification.hs @@ -0,0 +1,255 @@ +{- | +Module : Spec.Specification +Maintainer : seungheon.ooh@gmail.com +Description: Helpers to build Specification for testing and bench-marking + +Constructors for building a specification for Plutarch scripts: + + - '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.Specification ( + -- * Structures + Specification (..), + SpecificationExpectation (..), + SpecificationTree (..), + + -- * Spec helpers + group, + getSpecification, + getSpecificationTree, + + -- * Spec builders + scriptSucceeds, + scriptFails, + policySucceedsWith, + policyFailsWith, + validatorSucceedsWith, + validatorFailsWith, + effectSucceedsWith, + effectFailsWith, + + -- * Converters + toTestTree, +) where + +import Plutarch.Api.V1 (PMintingPolicy, PValidator) +import Plutarch.Builtin (pforgetData) +import Plutarch.Evaluate (evalScript) +import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) +import Plutus.V1.Ledger.Api (Script, ScriptContext) +import PlutusTx.IsData qualified as PlutusTx (ToData) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) + +{- | Expectations upon execution of script + @Success@ indicates a successful execution. + @Failure@ inidcates a faulty execution. + @FailureWith@ indicates a faulty execution but with expected reason for failure. +-} +data SpecificationExpectation + = Success + | Failure + | FailureWith String + deriving stock (Show) + +{- | Unit of specification. @Specification@ holds name, expectation, and + script to be tested or executed later on. +-} +data Specification = Specification + { sName :: String + , sExpectation :: SpecificationExpectation + , sScript :: Script + } + deriving stock (Show) + +-- | Tree-structure to group alike specifications--modeled after @TestTree@ from tasty. +data SpecificationTree + = Terminal Specification + | Group String [SpecificationTree] + deriving stock (Show) + +{- | Checks if given name exists in @SpecificationTree@ as either + group name or specification name. +-} +exists :: String -> SpecificationTree -> Bool +exists s (Terminal (Specification name _ _)) = s == name +exists s (Group name st) = or (exists s <$> st) || s == name + +-- | Groups alike @SpecificationTree@s into a bigger tree. +group :: String -> [SpecificationTree] -> SpecificationTree +group name st + | or $ exists name <$> st = error $ "Name already exists: " <> name + | otherwise = Group name st + +-- | Query specific @Specification@ from a tree. +getSpecification :: String -> SpecificationTree -> [Specification] +getSpecification name (Terminal spec@(Specification sn _ _)) + | name == sn = [spec] + | otherwise = [] +getSpecification name (Group _ st) = mconcat $ getSpecification name <$> st + +-- | Query specific @SpecificationTree@ from a tree. +getSpecificationTree :: String -> SpecificationTree -> [SpecificationTree] +getSpecificationTree name specTree@(Group gn st) + | gn == name = [specTree] + | otherwise = mconcat $ getSpecificationTree name <$> st +getSpecificationTree _ _ = [] + +-- | Convert @SpecificationTree@ into @TestTree@ to be used as a unit test. +toTestTree :: SpecificationTree -> TestTree +toTestTree (Group name st) = testGroup name $ toTestTree <$> st +toTestTree (Terminal (Specification name expectation script)) = + testCase name $ do + case expectation of + Success -> onSuccess + Failure -> onFailure + FailureWith s -> onFailureWith s + where + (res, _budget, traces) = evalScript script + ts = " Traces: " <> show traces + onSuccess = case res of + Left e -> + assertFailure $ + show e <> ts + _ -> pure () + onFailure = case res of + Right v -> + assertFailure $ + "Expected failure, but succeeded. " + <> show v + <> ts + _ -> pure () + onFailureWith _s = case res of -- TODO: check Trace for this + Right v -> + assertFailure $ + "Expected failure, but succeeded. " + <> show v + <> ts + _ -> pure () + +-- | Check that an arbitrary script doesn't error when evaluated, given a name. +scriptSucceeds :: String -> Script -> SpecificationTree +scriptSucceeds name script = Terminal $ Specification name Success script + +-- | Check that an arbitrary script **does** error when evaluated, given a name. +scriptFails :: String -> Script -> SpecificationTree +scriptFails name script = Terminal $ Specification name Failure script + +-- | Check that a policy script succeeds, given a name and arguments. +policySucceedsWith :: + ( PLift redeemer + , PlutusTx.ToData (PLifted redeemer) + ) => + String -> + ClosedTerm PMintingPolicy -> + PLifted redeemer -> + ScriptContext -> + SpecificationTree +policySucceedsWith tag policy redeemer scriptContext = + scriptSucceeds tag $ + compile + ( policy + # pforgetData (pconstantData redeemer) + # pconstant scriptContext + ) + +-- | Check that a policy script fails, given a name and arguments. +policyFailsWith :: + ( PLift redeemer + , PlutusTx.ToData (PLifted redeemer) + ) => + String -> + ClosedTerm PMintingPolicy -> + PLifted redeemer -> + ScriptContext -> + SpecificationTree +policyFailsWith tag policy redeemer scriptContext = + scriptFails tag $ + compile + ( policy + # pforgetData (pconstantData redeemer) + # pconstant scriptContext + ) + +-- | Check that a validator script succeeds, given a name and arguments. +validatorSucceedsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + , PLift redeemer + , PlutusTx.ToData (PLifted redeemer) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + PLifted redeemer -> + ScriptContext -> + SpecificationTree +validatorSucceedsWith tag validator datum redeemer scriptContext = + scriptSucceeds tag $ + compile + ( validator + # pforgetData (pconstantData datum) + # pforgetData (pconstantData redeemer) + # pconstant scriptContext + ) + +-- | Check that a validator script fails, given a name and arguments. +validatorFailsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + , PLift redeemer + , PlutusTx.ToData (PLifted redeemer) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + PLifted redeemer -> + ScriptContext -> + SpecificationTree +validatorFailsWith tag validator datum redeemer scriptContext = + scriptFails tag $ + compile + ( validator + # pforgetData (pconstantData datum) + # pforgetData (pconstantData redeemer) + # pconstant scriptContext + ) + +-- | Check that an effect succeeds, given a name and argument. +effectSucceedsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + SpecificationTree +effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () + +-- | Check that an effect fails, given a name and argument. +effectFailsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + SpecificationTree +effectFailsWith tag eff datum = validatorFailsWith tag eff datum () diff --git a/agora-test/Spec/Stake.hs b/agora-spec/Spec/Stake.hs similarity index 87% rename from agora-test/Spec/Stake.hs rename to agora-spec/Spec/Stake.hs index 3a3eacd..d48b7d2 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-spec/Spec/Stake.hs @@ -7,7 +7,7 @@ Description: Tests for Stake policy and validator Tests for Stake policy and validator -} -module Spec.Stake (tests) where +module Spec.Stake (specs) where -------------------------------------------------------------------------------- @@ -15,10 +15,6 @@ import Prelude -------------------------------------------------------------------------------- -import Test.Tasty (TestTree, testGroup) - --------------------------------------------------------------------------------- - import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw)) import Agora.Stake.Scripts (stakePolicy, stakeValidator) @@ -26,14 +22,21 @@ import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer) import Sample.Stake qualified as Stake -import Test.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWith, validatorSucceedsWith) +import Spec.Specification ( + SpecificationTree, + group, + policyFailsWith, + policySucceedsWith, + validatorFailsWith, + validatorSucceedsWith, + ) +import Test.Util (toDatum) -------------------------------------------------------------------------------- --- | Stake tests. -tests :: [TestTree] -tests = - [ testGroup +specs :: [SpecificationTree] +specs = + [ group "policy" [ policySucceedsWith "stakeCreation" @@ -51,7 +54,7 @@ tests = () Stake.stakeCreationUnsigned ] - , testGroup + , group "validator" [ validatorSucceedsWith "stakeDepositWithdraw deposit" diff --git a/agora-test/Spec/Treasury.hs b/agora-spec/Spec/Treasury.hs similarity index 92% rename from agora-test/Spec/Treasury.hs rename to agora-spec/Spec/Treasury.hs index 0cd139f..7f36e89 100644 --- a/agora-test/Spec/Treasury.hs +++ b/agora-spec/Spec/Treasury.hs @@ -5,7 +5,7 @@ Module: Spec.Treasury Description: Tests for Agora treasury. Maintainer: jack@mlabs.city -This module exports `tests`, a list of `TestTree`s, which ensure +This module exports `specs`, a list of `TestTree`s, which ensure that Agora's treasury component works as desired. Tests need to fail when: @@ -19,7 +19,7 @@ Tests need to fail when: ii. A script has a GAT, the token name for which does /not/ match the script's validator hash. -} -module Spec.Treasury (tests) where +module Spec.Treasury (specs) where import Agora.Treasury ( TreasuryRedeemer (SpendTreasuryGAT), @@ -48,14 +48,18 @@ import Sample.Treasury ( validCtx, walletIn, ) -import Test.Tasty (TestTree, testGroup) -import Test.Util (validatorFailsWith, validatorSucceedsWith) +import Spec.Specification ( + SpecificationTree, + group, + validatorFailsWith, + validatorSucceedsWith, + ) -tests :: [TestTree] -tests = - [ testGroup +specs :: [SpecificationTree] +specs = + [ group "Validator" - [ testGroup + [ group "Positive" [ validatorSucceedsWith "Allows for effect changes" @@ -64,9 +68,9 @@ tests = SpendTreasuryGAT validCtx ] - , testGroup + , group "Negative" - [ testGroup + [ group "Fails with ScriptPurpose not Minting" [ validatorFailsWith "Spending" diff --git a/agora-test/Spec/Utils.hs b/agora-spec/Spec/Utils.hs similarity index 100% rename from agora-test/Spec/Utils.hs rename to agora-spec/Spec/Utils.hs diff --git a/agora-test/README.org b/agora-test/README.org deleted file mode 100644 index d7e7d2c..0000000 --- a/agora-test/README.org +++ /dev/null @@ -1,11 +0,0 @@ -#+Title: Agora Test -This folder is the test suite for Agora governance system. - -- =/Spec= contains different tests for different elements of Agora. -- =/Spec/Model= contain =apropos-tx= model for logical suite - generation and tests. -- =/Spec/Sample= contains primitive hand-made example values. -- =Util.hs= contains helper functions - -Currently, planning to introduce =plutarch-test= for unit tests, -benchmarks, and golden tests. diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 2d97c1e..aca4d05 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -2,6 +2,7 @@ import Prelude -------------------------------------------------------------------------------- +import GHC.IO.Encoding (setLocaleEncoding, utf8) import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- @@ -16,39 +17,26 @@ import Spec.Stake qualified as Stake import Spec.Treasury qualified as Treasury import Spec.Utils qualified as Utils +import Spec.Specification (group, toTestTree) + -- | The Agora test suite. main :: IO () -main = +main = do + setLocaleEncoding utf8 defaultMain $ testGroup "test suite" [ testGroup "Effects" - [ testGroup - "Treasury Withdrawal Effect" - TreasuryWithdrawal.tests - , testGroup - "Governor Mutation Effect" - GovernorMutation.tests + [ toTestTree $ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs + , toTestTree $ group "Governor Mutation Effect" GovernorMutation.specs ] - , testGroup - "Stake tests" - Stake.tests - , 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 + , toTestTree $ group "Stake tests" Stake.specs + , toTestTree $ group "Proposal tests" Proposal.specs + , toTestTree $ group "AuthorityToken tests" AuthorityToken.specs + , toTestTree $ group "Treasury tests" Treasury.specs + , toTestTree $ group "AuthorityToken tests" AuthorityToken.specs + , toTestTree $ group "Governor tests" Governor.specs , testGroup "Utility tests" Utils.tests diff --git a/agora-testlib/Test/Util.hs b/agora-testlib/Test/Util.hs index ab750d1..030ae28 100644 --- a/agora-testlib/Test/Util.hs +++ b/agora-testlib/Test/Util.hs @@ -2,37 +2,8 @@ Module : Test.Util Maintainer : emi@haskell.fyi Description: 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 Test.Util ( - -- * Testing utils - scriptSucceeds, - scriptFails, - policySucceedsWith, - policyFailsWith, - validatorSucceedsWith, - validatorFailsWith, - effectSucceedsWith, - effectFailsWith, - -- * Plutus-land utils datumHash, toDatum, @@ -53,19 +24,9 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy -------------------------------------------------------------------------------- -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (assertFailure, testCase) - --------------------------------------------------------------------------------- - -import Plutarch.Api.V1 (PMintingPolicy, PValidator) -import Plutarch.Builtin (pforgetData) import Plutarch.Crypto (pblake2b_256) -import Plutarch.Evaluate (evalScript) -import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) -import Plutus.V1.Ledger.Contexts (ScriptContext) import Plutus.V1.Ledger.Interval as PlutusTx -import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script) +import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash)) import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.IsData qualified as PlutusTx @@ -73,140 +34,6 @@ import PlutusTx.Ord qualified as PlutusTx -------------------------------------------------------------------------------- --- | Check that a policy script succeeds, given a name and arguments. -policySucceedsWith :: - ( PLift redeemer - , PlutusTx.ToData (PLifted redeemer) - ) => - String -> - ClosedTerm PMintingPolicy -> - PLifted redeemer -> - ScriptContext -> - TestTree -policySucceedsWith tag policy redeemer scriptContext = - scriptSucceeds tag $ - compile - ( policy - # pforgetData (pconstantData redeemer) - # pconstant scriptContext - ) - --- | Check that a policy script fails, given a name and arguments. -policyFailsWith :: - ( PLift redeemer - , PlutusTx.ToData (PLifted redeemer) - ) => - String -> - ClosedTerm PMintingPolicy -> - PLifted redeemer -> - ScriptContext -> - TestTree -policyFailsWith tag policy redeemer scriptContext = - scriptFails tag $ - compile - ( policy - # pforgetData (pconstantData redeemer) - # pconstant scriptContext - ) - --- | Check that a validator script succeeds, given a name and arguments. -validatorSucceedsWith :: - ( PLift datum - , PlutusTx.ToData (PLifted datum) - , PLift redeemer - , PlutusTx.ToData (PLifted redeemer) - ) => - String -> - ClosedTerm PValidator -> - PLifted datum -> - PLifted redeemer -> - ScriptContext -> - TestTree -validatorSucceedsWith tag validator datum redeemer scriptContext = - scriptSucceeds tag $ - compile - ( validator - # pforgetData (pconstantData datum) - # pforgetData (pconstantData redeemer) - # pconstant scriptContext - ) - --- | Check that a validator script fails, given a name and arguments. -validatorFailsWith :: - ( PLift datum - , PlutusTx.ToData (PLifted datum) - , PLift redeemer - , PlutusTx.ToData (PLifted redeemer) - ) => - String -> - ClosedTerm PValidator -> - PLifted datum -> - PLifted redeemer -> - ScriptContext -> - TestTree -validatorFailsWith tag validator datum redeemer scriptContext = - scriptFails tag $ - compile - ( validator - # pforgetData (pconstantData datum) - # pforgetData (pconstantData redeemer) - # pconstant scriptContext - ) - -{- | Check that a validator script succeeds, given a name and arguments. - TODO: Change docstring. --} -effectSucceedsWith :: - ( PLift datum - , PlutusTx.ToData (PLifted datum) - ) => - String -> - ClosedTerm PValidator -> - PLifted datum -> - ScriptContext -> - TestTree -effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () - --- TODO: Change docstring. - -{- | Check that a validator script fails, given a name and arguments. - TODO: Change docstring. --} -effectFailsWith :: - ( PLift datum - , PlutusTx.ToData (PLifted datum) - ) => - String -> - ClosedTerm PValidator -> - PLifted datum -> - ScriptContext -> - TestTree -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 -scriptSucceeds name script = testCase name $ do - let (res, _budget, traces) = evalScript script - case res of - Left e -> do - assertFailure $ - show e <> " Traces: " <> show traces - Right _v -> - pure () - --- | Check that an arbitrary script **does** error when evaluated, given a name. -scriptFails :: String -> Script -> TestTree -scriptFails name script = testCase name $ do - let (res, _budget, traces) = evalScript script - case res of - Left _e -> - pure () - Right v -> - assertFailure $ - "Expected failure, but succeeded. " <> show v <> " Traces: " <> show traces - --------------------------------------------------------------------------------- - {- | Create a pair from data for use in 'txInfoData'. Example: diff --git a/agora.cabal b/agora.cabal index 256e025..8797761 100644 --- a/agora.cabal +++ b/agora.cabal @@ -179,26 +179,35 @@ library agora-sample hs-source-dirs: agora-sample build-depends: agora-testlib -test-suite agora-test - import: lang, deps, test-deps - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: agora-test - other-modules: +library agora-spec + import: lang, deps, test-deps + exposed-modules: Spec.AuthorityToken Spec.Effect.GovernorMutation Spec.Effect.TreasuryWithdrawal Spec.Governor Spec.Model.MultiSig Spec.Proposal + Spec.Specification Spec.Stake Spec.Treasury Spec.Utils + hs-source-dirs: agora-spec build-depends: , agora-sample , agora-testlib +test-suite agora-test + import: lang, deps, test-deps + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: agora-test + build-depends: + , agora-sample + , agora-spec + , agora-testlib + benchmark agora-bench import: lang, deps hs-source-dirs: agora-bench @@ -208,6 +217,8 @@ benchmark agora-bench build-depends: , agora , agora-sample + , agora-spec + , cassava executable agora-scripts import: lang, deps, exe-opts diff --git a/bench.csv b/bench.csv index ef76a58..ab8954d 100644 --- a/bench.csv +++ b/bench.csv @@ -1,4 +1,23 @@ name,cpu,mem,size -full_scripts:authorityTokenPolicy,1756707,6000,841 -full_scripts:stakePolicy,3751498,12700,1610 -full_scripts:stakeValidator,3126265,10600,1500 +Agora/Effects/Treasury Withdrawal Effect/effect/Simple,340268715,724428,3050 +Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,570029812,1211300,3377 +Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,502351827,1071087,3242 +Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,103651824,228328,7681 +Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,126986096,263635,3357 +Agora/Stake/policy/stakeCreation,60250773,128585,2144 +Agora/Stake/validator/stakeDepositWithdraw deposit,275919558,599033,4063 +Agora/Stake/validator/stakeDepositWithdraw withdraw,275919558,599033,4055 +Agora/Proposal/policy/proposalCreation,34571405,70066,1585 +Agora/Proposal/validator/cosignature/proposal,240007066,509127,4892 +Agora/Proposal/validator/cosignature/stake,185913543,402497,4600 +Agora/Proposal/validator/voting/proposal,238383906,489848,4900 +Agora/Proposal/validator/voting/stake,153804848,328239,4653 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900 +Agora/Treasury/Validator/Positive/Allows for effect changes,37343572,79744,1841 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900 +Agora/Governor/policy/GST minting,57648280,119961,1851 +Agora/Governor/validator/proposal creation,329287002,679689,8196 +Agora/Governor/validator/GATs minting,430385143,929607,8319 +Agora/Governor/validator/mutate governor state,100840784,222602,7738