Merge pull request #244 from Liqwid-Labs/kylix/bump-liqwid-libs

bump liqwid-libs

.github/pull_request_template.md

@@ -0,0 +1,11 @@
+## Describe your changes
+
+## Relevant issues
+
+## Checklist before requesting a review.
+
+- [ ] I have ensured documentation and testing are thorough.
+- [ ] I have updated the changelog.
+- [ ] I have read [CONTRIBUTING.md](../CONTRIBUTING.md)
+- [ ] I have made sure the CI checks run using `nix run .#ci`.
+- [ ] I have followed the code standards to the best of my ability or have documented carefully where and why I haven't.

.gitignore

@@ -25,3 +25,8 @@ TAGS
 # Haddock files and Hoogle databases 
 haddock 
 hoo
+
+.pre-commit-config.yaml
+
+agora-test/goldens/agora.json
+agora-test/goldens/agoraDebug.json

CHANGELOG.md

@@ -4,11 +4,193 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
 
 ## Unreleased (Candidate for 1.0.0)
 
+### Added
+
+- Golden tests for the script exports.
+
+### Modified
+
+- For consistency and performance, the following data types are encoded as flat
+product as opposed to SoP now:
+
+  - `GovernorDatum`
+  - `ProposalThresholds`
+  - `ProposalTimingConfig`
+  - `MutateGovernorDatum`
+  - `TreasuryWithdrawalDatum`
+
+  Included by [#231](https://github.com/Liqwid-Labs/agora/pull/231)
+
+- Fix several vulnerabilities and bugs found by auditors.
+
+  Including:
+  - Stake locks can be removed without retracting votes. This is a bug
+    introduced in the refactoring of `premoveLocks` by #209.
+  - Stake can retract all votes in its cooldown period.
+  - Inconsistent delegate authority checking may fail in some cases, where the
+    delegate votes with own and delegated stakes.
+  
+  Included by [#212](https://github.com/Liqwid-Labs/agora/pull/212)
+
+- Mitigate potential DDoS attack(voting and unlocking repeatedly)
+
+  We fix this issue by posing cooldown time while retracting votes, encoded in  
+  `ProposalTimingConfig`'s `minStakeVotingTime` field. Also to make sure that
+  stake owners can unlock their stakes in s reasonable time, we pose a maximum
+  time range width requirement while voting, encoded in `ProposalTimingConfig`'s `votingTimeRangeMaxWidth` field.
+
+  Included by [#209](https://github.com/Liqwid-Labs/agora/pull/209)
+
+- Fix several vulnerabilities and bugs found by auditors.
+
+  Including:
+  - A bug that allows multiple GATs to be minted into a single UTxO and sent
+    to a malicious script.
+  - A bug that allows delegates to create or cosign proposals with delegated
+    stakes.
+  - Potential DDoS attack: calling `UnlockStake` without any stake.
+  - Potential DDoS attack: calling `UnlockStake` on a `VotingReady` proposal
+    without actually changing the votes.
+  - Ignore staking credential in proposal, stake and governor.
+  - Improve naming and doc strings to avoid confusion.
+
+  Included by [#208](https://github.com/Liqwid-Labs/agora/pull/208)
+
+- Allow delegates to vote and retract vote with their stakes along side with
+  stakes delegated to them in the same transaction.
+
+  Included by [#208](https://github.com/Liqwid-Labs/agora/pull/208)
+
+- Fix several vulnerabilities and bugs found in both proposal and governor scripts.
+
+  Including:
+
+  - Governor accepts fake stake UTxO, meaning that an attacker can DoS by
+    creating Proposals without passing the minimum GT limit.
+  - The proposal policy asserts that GST moves while minting PST, effectively
+    allowing attackers to create fake proposals.
+
+- Fix an exploit that allows arbitrary amount of SSTs to be minted. The attack is
+  very similar to the GAT one. See also the discussion in
+  [#202](https://github.com/Liqwid-Labs/agora/pull/202).
+
+  Included by [#203](https://github.com/Liqwid-Labs/agora/pull/203)
+
+- Fix an exploit that allows burning `m` legitimate GATs from faulty effect
+  validators to mint `n` (`n` < `m`) illegitimate GAT.
+
+  Included by [#203](https://github.com/Liqwid-Labs/agora/pull/203)
+
+- Fix several vulnerabilities and bugs found in both staking and proposal components.
+
+  Including:
+
+  - Proposal thresholds should be inclusively checked.
+  - Attackers can fail any voted-on/locked proposal, or fast track to `Finished`,
+    by constructing a transaction that has a very loose valid time range.
+  - The stake validator can be fooled by stakes that doesn't belong to itself, and
+    consequently allows attack to down vote without voting.
+  - Improve doc string of `authorityTokensValidIn` to avoid confusion.
+  - Rename proposal redeemer `Unlock` to `UnlockStake` to avoid confusion.
+
+  Included by [#200](https://github.com/Liqwid-Labs/agora/pull/200)
+
+- Fix a bug where `lockedBy` and `delegatedTo` fields of stake datums aren't checked
+  during the creation of stakes.
+
+  Included by [#199](https://github.com/Liqwid-Labs/agora/pull/199)
+
+- Fix several vulnerabilities and bugs found in staking components.
+  
+  Including:
+
+  - Stake state token can be taken away
+  - Privilege escalation: Acting on behalf of delegatee role + Unlocking delegated stakes
+  - Delegatee can steal delegated inputs
+  - Stake policy doesn't allow destroying multiple stakes
+
+  Included by [#195](https://github.com/Liqwid-Labs/agora/pull/195)
+
+- Place a lock the stake while cosigning a proposal.
+
+  NOTE: This changes how cosigning works. In particular, the stake has to be
+  spent instead of just presented in the reference inputs. Also, adding multiple
+  cosignatures in one tx is no longer possible.
+
+  Included by [#192](https://github.com/Liqwid-Labs/agora/pull/192)
+
+- Support voting/retracting votes with multiple stakes.
+
+  NOTE: Due to the fact that the order of stake locks is undefined, voting to
+   multiple proposals in a single tx is disallowed.
+  
+  Included by [#186](https://github.com/Liqwid-Labs/agora/pull/186)
+
+- Fix a bug that allows an attacker to send two or more GATs to an effect in the winning effect group.
+
+  Fixed by [#181](https://github.com/Liqwid-Labs/agora/pull/181)
+
+- Workaround `currentProposalTime` always returns `PNothing`, due to the fact
+ that upper bound of `txInfoValidRange` is never closed.
+
+  Fixed by [#177](https://github.com/Liqwid-Labs/agora/pull/177)
+
+- Fixed governor validator always fail because of the 0 ADA entry in
+ `txInfoF.mint`. (#174)
+
+  Fixed by [#175](https://github.com/Liqwid-Labs/agora/pull/175)
+
+- Standalone stake redeemers. This allows injecting custom validation logic to
+the stake validator easily. The behaviour of the default stake validator remains
+ unchanged.
+
+  Included by [#172](https://github.com/Liqwid-Labs/agora/pull/172)
+
+- Witness stakes with reference input. Stake redeemer `WitnessStake` is removed.
+
+  Included by [#168](https://github.com/Liqwid-Labs/agora/pull/168)
+
+- `tracing` flag in `ScriptParams` of `agora-scripts` to enable/disable tracing in exported scripts.
+
+  NOTE: This changes the representation of `ScriptParams`. In order to preserve old behavior, the flag
+  must be set to `True`.
+  
+  Included by [#167](https://github.com/Liqwid-Labs/agora/pull/167).
+
+- `effects` of `Proposaldatum` is now required to be sorted in ascending order. The uniqueness of result tags is also guaranteed.
+
+  `ProposalVotes` should be sorted the same way as a result.
+
+- AuthCheck script is used for tagging GAT TokenName instead of effect script
+  it is deployed at.
+  
+  Included by [#161](https://github.com/Liqwid-Labs/agora/pull/161).
+
+- Use `Credential` instead of `PubKeyHash`
+
+  Included by [#158](https://github.com/Liqwid-Labs/agora/pull/158).
+
+  NOTE: This changes the representation of the following types:
+  
+  - `PStakeDatum`
+  - `PStakeRedeemer`
+  - `PProposalDatum`
+  - `PProposalRedeemer`
+
+- Use plutus v2 types.
+
+  Included by [#156](https://github.com/Liqwid-Labs/agora/pull/156).
+
+- Expected input datum value is pinned instead of out ref for governor mutation
+  effect.
+  
+  Included by [#238](https://github.com/Liqwid-Labs/agora/pull/238).
+
 ## 0.2.0 -- 2022-08-13
 
 ### Added
 
-- Script exporting with `plutarch-script-export` 
+- Script exporting with `plutarch-script-export`.
 
 ### Modified
 
@@ -28,7 +210,7 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
 
   Included by [#146](https://github.com/Liqwid-Labs/agora/pull/146).
 
-- Draft phase and cosigning for Proposals. 
+- Draft phase and cosigning for Proposals.
 
   Included by [#136](https://github.com/Liqwid-Labs/agora/pull/136).
 
@@ -36,7 +218,7 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
 
   Included by [#134](https://github.com/Liqwid-Labs/agora/pull/134).
   
-- Fixed bug that made it impossible to create proposals. Added new stake locking mechanism for creating proposals. 
+- Fixed bug that made it impossible to create proposals. Added new stake locking mechanism for creating proposals.
   
   Included by [#142](https://github.com/Liqwid-Labs/agora/pull/142).
   

CONTRIBUTING.md

@@ -11,6 +11,7 @@ Please follow the [Git policy](https://liqwid.notion.site/Git-Policy-9a7979b2fd5
 This document will make reference to the _Agora core team_. These are the people who work on Agora professionally and will be responsible for maintaining the project in its open source life. They include:
 
 - [Emily Martins](https://github.com/emiflake)
+- [Connor Fang](https://github.com/chfanghr)
 - [Jack Hodgkinson](https://github.com/jhodgdev)
 
 ## Issues
@@ -33,7 +34,7 @@ If you wish to work to resolve the issue, the Agora team would invite you to sub
 
 Only those within the core Agora team may contribute work to the project directly. If you wish to work on the project, you must [fork](https://docs.github.com/en/get-started/quickstart/fork-a-repo) the repository and submit your changes to your fork. Instructions for getting started with the project may be found in the [README](./README.md). Once the work on your fork is completed, you may submit a PR [here](https://github.com/Liqwid-Labs/agora/pulls).
 
-Before submitting a PR, please write an issue pertaining to the problem that your PR would solve e.g. a bug in the codebase or a missing feature. Read this document's section on _Issues_ and pay particular heed to the paragraph asking contributors to _look for pre-existing issues_. The prior experiences of existing contributors could save you a significant amount of time and effort. It is possible that a number of issues could be solved by your PR. Please reference any issues that would be ameliorated by your PR - including your own issue, if you have written one - clearly. Please label your PR using GitHub's tagging feature. Please state plainly:
+If your PR fixes an issue that isn't a very obvious bug, or has not previously been discussed, please write an issue pertaining to the problem that your PR would solve. Read this document's section on _Issues_ and pay particular heed to the paragraph asking contributors to _look for pre-existing issues_. The prior experiences of existing contributors could save you a significant amount of time and effort. It is possible that a number of issues could be solved by your PR. Please reference any issues that would be ameliorated by your PR - including your own issue, if you have written one - clearly. Please label your PR using GitHub's tagging feature. Please state plainly:
 
 - What your PR achieves.
 - How your PR works.
@@ -46,23 +47,17 @@ Contributors should expect that if their work is insufficiently documented (eith
 
 Agora utilises [Plutarch](https://github.com/plutonomicon/plutarch) and your work must be written with Plutarch, when appropriate. Plutarch can prove _complicated_ but the documentation is extensive. We would encourage you to dive deeply into the documentation, whilst stating that Plutarch's [Tricks.md](https://github.com/Plutonomicon/plutarch/blob/master/docs/Tricks.md) could prove particularly helpful.
 
-### Stylistic guidelines
-
-All work must comply with the [MLabs style guide](https://github.com/mlabs-haskell/styleguide/).
-
 ### Continuous integration
 
-For your PR to be merged it must pass three automated checks:
+For your PR to be merged it must pass the CI checks.
 
-1. A [`fourmolu`](https://github.com/fourmolu/fourmolu) formatting check.
-2. A [`hlint`](https://github.com/ndmitchell/hlint) linting check.
-3. A Cabal build check.
+These can be run locally by running `nix run .#ci`. If you are making a PR through a fork of the repository, they might not be run in CI. When this is the case, please ensure the CI checks run fine locally before you request a review.
 
-Our custom `fourmolu` rules may be found in the [base of the repository](./fourmolu.yaml). You can ensure that your work will pass CI by:
+## Standards
 
-1. Running `make format` from the included `Makefile`.
-2. Running `make lint` from the included `Makefile` and applying any recommendations.
-3. Ensuring that `cabal build` terminates successfully on your machine in the provided Nix environment.
+Agora follows strict standards to increase consistency, to minimize
+the impact of legacy, to properly use automated tools, and more. The standards document
+can be found [here](https://liqwid.notion.site/Coding-Standards-cd3c430e6e444fa292ecc3c57b7d95eb).
 
 ## Documentation
 

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 tag format_nix format_haskell format_check	\ 
+.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check	\
 				lint refactor ps_bridge bench bench_check scripts test build ci
 
 SOURCE_FILES := $(shell git ls-tree -r HEAD --full-tree --name-only)
@@ -98,4 +98,6 @@ test: requires_nix_shell
 build: requires_nix_shell
 	cabal build -j$(THREADS)
 
-ci: format_check lint build bench_check test haddock
+ci:
+	@ [[ "$$(uname -sm)" == "Linux x86_64" ]] || (echo "NOTE: CI only builds on Linux x86_64. Your system is $$(uname -sm), continuing...")
+	nix build .#checks.$(shell nix eval -f '<nixpkgs>' system).required

README.md

@@ -6,7 +6,7 @@ Agora is a set of Plutus scripts that compose together to form a governance syst
 
 Goals:
 
--   Agora aims to reduce duplication in Liqwid and LiqwidX and to serve as a one-size-fits-all governance library for projects on the Cardano blockchain.
+-   Agora aims to reduce duplication in Liqwid and XplorerDAO and to serve as a one-size-fits-all governance library for projects on the Cardano blockchain.
 -   Agora aims to be modular and flexible for specific needs but presents an opinionated architecture.
 
 Non-goals:
@@ -34,9 +34,7 @@ cabal run agora-scripts -- --enable-cors-middleware
 
 ## Documentation
 
-Documentation for Agora is hosted on Notion. You can find the specs [here](https://liqwid.notion.site/e85c09d2c9a542b19aac8dd3d6caa98b?v=d863219cd6a14082a661c4959cabd6e7).
-
-Haddock is deployed on GitHub Pages [here](https://liqwid-labs.github.io/agora/).
+Documentation for Agora is hosted on Notion. You can find the specs [here](https://liqwid.notion.site/Agora-Specs-Overview-fd7df78313cf4dc0b1522cb9260b77d1).
 
 ### Using Agora for your protocol
 
@@ -64,11 +62,12 @@ Please read [CONTRIBUTING.md](./CONTRIBUTING.md). Additionally, please follow th
 
 ### v2
 
--   [ ] Rewards distribution
--   [ ] Escrow staking pool solution
+-   [ ] Flexible scripts using TxT pattern integrated with governance
+-   [ ] Different voting mechanisms
 
 ### Available support channels info
 
 You can find help, more information and ongoing discusion about the project here:
 
 - The [Agora & Liqwid Libs Discord](https://discord.gg/yGkjxrYueB) - Most Agora discussion happens here.
+- Specs, issues, and project-management-related information is tracked on [Notion](https://www.notion.so/liqwid)

agora-bench/Bench.hs

@@ -2,18 +2,16 @@
 
 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.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
 import Data.List (intercalate)
 import Data.Text (Text, pack)
 import Plutarch.Evaluate (evalScript)
-import PlutusLedgerApi.V1 (
+import Plutarch.Script (Script, serialiseScript)
+import PlutusLedgerApi.V2 (
   ExBudget (ExBudget),
   ExCPU (..),
   ExMemory (..),
-  Script,
  )
 import Prettyprinter (Pretty (pretty), indent, vsep)
 import Test.Specification (
@@ -66,7 +64,7 @@ benchmarkScript name script = Benchmark (pack name) cpu mem size
   where
     (_res, ExBudget cpu mem, _traces) = evalScript script
 
-    size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
+    size = SBS.length . serialiseScript $ script
 
 specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark]
 specificationTreeToBenchmarks = go []

agora-bench/Main.hs

@@ -4,7 +4,7 @@ import Bench (specificationTreeToBenchmarks)
 import Data.Csv (EncodeOptions (encUseCrLf), defaultEncodeOptions, encodeDefaultOrderedByNameWith)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Text.Lazy.IO as I (putStr, writeFile)
-import Options (Options (..), parseOptions)
+import Options (Options (output), parseOptions)
 import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
 import Prettyprinter.Render.Text (renderLazy)
 import Spec.AuthorityToken qualified as AuthorityToken
@@ -16,7 +16,6 @@ import Spec.Stake qualified as Stake
 import Spec.Treasury qualified as Treasury
 import System.IO (hIsTerminalDevice, stdout)
 import Test.Specification (group)
-import Prelude
 
 --------------------------------------------------------------------------------
 

agora-purescript-bridge/AgoraTypes.hs

@@ -11,13 +11,11 @@ import Language.PureScript.Bridge (
 
 --------------------------------------------------------------------------------
 
-import Agora.AuthorityToken qualified as AuthorityToken
 import Agora.Effect.GovernorMutation qualified as GovernorMutation
 import Agora.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawalEffect
 import Agora.Governor qualified as Governor
 import Agora.Proposal qualified as Proposal
 import Agora.Stake qualified as Stake
-import Agora.Treasury qualified as Treasury
 
 --------------------------------------------------------------------------------
 
@@ -39,10 +37,6 @@ agoraTypes =
     mkSumType (Proxy @Stake.ProposalLock)
   , mkSumType (Proxy @Stake.StakeRedeemer)
   , mkSumType (Proxy @Stake.StakeDatum)
-  , -- Treasury
-    mkSumType (Proxy @Treasury.TreasuryRedeemer)
-  , -- AuthorityToken
-    mkSumType (Proxy @AuthorityToken.AuthorityToken)
   , -- Effects
     mkSumType (Proxy @TreasuryWithdrawalEffect.TreasuryWithdrawalDatum)
   , mkSumType (Proxy @GovernorMutation.MutateGovernorDatum)

agora-scripts/Main.hs

@@ -8,157 +8,43 @@
 -}
 module Main (main) where
 
+import Agora.Bootstrap (alwaysSucceedsPolicyRoledScript)
 import Agora.Bootstrap qualified as Bootstrap
-import Agora.Governor (Governor (..))
-import Agora.SafeMoney (GTTag)
-import Agora.Scripts qualified as Scripts
-import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..))
+import Agora.Linker (linker)
 import Data.Aeson qualified as Aeson
 import Data.Default (def)
-import Data.Function ((&))
-import Data.Tagged (Tagged)
-import Data.Text (Text)
-import Development.GitRev (gitBranch, gitHash)
-import GHC.Generics qualified as GHC
-import Plutarch (Config (..), TracingMode (DoTracing))
-import PlutusLedgerApi.V1 (
-  MintingPolicy (getMintingPolicy),
-  TxOutRef,
-  Validator (getValidator),
+import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
+import Ply (TypedScriptEnvelope)
+import ScriptExport.Export (exportMain)
+import ScriptExport.Types (
+  Builders,
+  insertBuilder,
+  insertScriptExportWithLinker,
+  insertStaticBuilder,
  )
-import PlutusLedgerApi.V1.Value (AssetClass)
-import ScriptExport.API (runServer)
-import ScriptExport.Options (parseOptions)
-import ScriptExport.ScriptInfo (ScriptInfo (..), mkPolicyInfo, mkScriptInfo, mkValidatorInfo)
-import ScriptExport.Types (Builders, insertBuilder)
 
 main :: IO ()
-main =
-  parseOptions >>= runServer revision builders
-  where
-    -- This encodes the git revision of the server. It's useful for the caller
-    -- to be able to ensure they are compatible with it.
-    revision :: Text
-    revision = $(gitBranch) <> "@" <> $(gitHash)
+main = exportMain builders
 
-{- | Builders for Agora scripts.
+rawScripts :: Config -> [TypedScriptEnvelope]
+rawScripts conf =
+  either (error . show) id $ Bootstrap.agoraScripts' conf
 
-     @since 0.2.0
--}
 builders :: Builders
 builders =
-  def
-    -- Agora scripts
-    & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts)
-    & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts)
-    & insertBuilder "stakePolicy" ((.stakePolicyInfo) . agoraScripts)
-    & insertBuilder "stakeValidator" ((.stakeValidatorInfo) . agoraScripts)
-    & insertBuilder "proposalPolicy" ((.proposalPolicyInfo) . agoraScripts)
-    & insertBuilder "proposalValidator" ((.proposalValidatorInfo) . agoraScripts)
-    & insertBuilder "treasuryValidator" ((.treasuryValidatorInfo) . agoraScripts)
-    & insertBuilder "authorityTokenPolicy" ((.authorityTokenPolicyInfo) . agoraScripts)
-    -- Trivial scripts. These are useful for testing, but they likely aren't useful
-    -- to you if you are actually interested in deploying to mainnet.
-    & insertBuilder
-      "alwaysSucceedsPolicy"
-      (\() -> mkPolicyInfo $ plam $ \_ _ -> popaque (pconstant ()))
-    & insertBuilder
-      "alwaysSucceedsValidator"
-      (\() -> mkValidatorInfo $ plam $ \_ _ _ -> popaque (pconstant ()))
-    & insertBuilder
-      "neverSucceedsPolicy"
-      (\() -> mkPolicyInfo $ plam $ \_ _ -> perror)
-    & insertBuilder
-      "neverSucceedsValidator"
-      (\() -> mkValidatorInfo $ plam $ \_ _ _ -> perror)
-
-{- | Create scripts from params.
-
-     @since 0.2.0
--}
-agoraScripts :: ScriptParams -> AgoraScripts
-agoraScripts params =
-  AgoraScripts
-    { governorPolicyInfo = mkPolicyInfo' scripts.compiledGovernorPolicy
-    , governorValidatorInfo = mkValidatorInfo' scripts.compiledGovernorValidator
-    , stakePolicyInfo = mkPolicyInfo' scripts.compiledStakePolicy
-    , stakeValidatorInfo = mkValidatorInfo' scripts.compiledStakeValidator
-    , proposalPolicyInfo = mkPolicyInfo' scripts.compiledProposalPolicy
-    , proposalValidatorInfo = mkValidatorInfo' scripts.compiledProposalValidator
-    , treasuryValidatorInfo = mkValidatorInfo' scripts.compiledTreasuryValidator
-    , authorityTokenPolicyInfo = mkPolicyInfo' scripts.compiledAuthorityTokenPolicy
-    }
-  where
-    governor =
-      Agora.Governor.Governor
-        params.governorInitialSpend
-        params.gtClassRef
-        params.maximumCosigners
-
-    scripts = Bootstrap.agoraScripts plutarchConfig governor
-
-{- | Params required for creating script export.
-
-     @since 0.2.0
--}
-data ScriptParams where
-  ScriptParams ::
-    { governorInitialSpend :: TxOutRef
-    , gtClassRef :: Tagged GTTag AssetClass
-    , maximumCosigners :: Integer
-    } ->
-    ScriptParams
-  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
-  deriving stock (Show, Eq, GHC.Generic, Ord)
-
-{- | Scripts that get exported.
-
-     @since 0.2.0
--}
-data AgoraScripts = AgoraScripts
-  { governorPolicyInfo :: ScriptInfo
-  , governorValidatorInfo :: ScriptInfo
-  , stakePolicyInfo :: ScriptInfo
-  , stakeValidatorInfo :: ScriptInfo
-  , proposalPolicyInfo :: ScriptInfo
-  , proposalValidatorInfo :: ScriptInfo
-  , treasuryValidatorInfo :: ScriptInfo
-  , authorityTokenPolicyInfo :: ScriptInfo
-  }
-  deriving anyclass
-    ( -- | @since 0.2.0
-      Aeson.ToJSON
-    , -- | @since 0.2.0
-      Aeson.FromJSON
-    )
-  deriving stock
-    ( -- | @since 0.2.0
-      Show
-    , -- | @since 0.2.0
-      Eq
-    , -- | @since 0.2.0
-      GHC.Generic
-    )
-
-{- | Default plutarch configuration for compiling scripts.
-
-     TODO: we should have an option to control this.
-
-     @since 0.2.0
--}
-plutarchConfig :: Config
-plutarchConfig = Config {tracingMode = DoTracing}
-
-{- | Turn a precompiled minting policy to a 'ScriptInfo'.
-
-     @since 0.2.0
--}
-mkPolicyInfo' :: forall redeemer. CompiledMintingPolicy redeemer -> ScriptInfo
-mkPolicyInfo' = mkScriptInfo . getMintingPolicy . getCompiledMintingPolicy
-
-{- | Turn a precompiled validator to a 'ScriptInfo'.
-
-     @since 0.2.0
--}
-mkValidatorInfo' :: forall redeemer datum. CompiledValidator datum redeemer -> ScriptInfo
-mkValidatorInfo' = mkScriptInfo . getValidator . getCompiledValidator
+  mconcat
+    [ insertStaticBuilder "raw" (rawScripts (Config NoTracing))
+    , insertStaticBuilder "rawDebug" (rawScripts (Config DoTracing))
+    , insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker
+    , insertScriptExportWithLinker
+        "agoraDebug"
+        ( Bootstrap.agoraScripts
+            (Config DoTracing)
+        )
+        linker
+    , -- Note: To be compatible with current off-chain setup, we are not using
+      --  static builder here.
+      insertBuilder
+        "alwaysSucceedsPolicy"
+        (const @_ @Aeson.Value alwaysSucceedsPolicyRoledScript)
+    ]

agora-scripts/sampleGov.json

@@ -0,0 +1,15 @@
+{
+  "gstOutRef": {
+    "txOutRefId": "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d",
+    "txOutRefIdx": 1
+  },
+  "gtClassRef": {
+    "name": {
+      "unTokenName": "3334363333353331"
+    },
+    "symbol": {
+      "unCurrencySymbol": "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
+    }
+  },
+  "maximumCosigners": 20
+}

agora-specs/Property/Generator.hs

@@ -32,22 +32,22 @@ import Plutarch.Context (
   output,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  Address (Address),
-  Credential (..),
-  PubKeyHash (PubKeyHash),
-  TxId (..),
-  TxOutRef (..),
-  ValidatorHash (ValidatorHash),
-  Value,
-  toBuiltin,
- )
 import PlutusLedgerApi.V1.Value (
   AssetClass (AssetClass),
   assetClassValue,
   currencySymbol,
   tokenName,
  )
+import PlutusLedgerApi.V2 (
+  Address (Address),
+  Credential (..),
+  PubKeyHash (PubKeyHash),
+  ScriptHash (ScriptHash),
+  TxId (..),
+  TxOutRef (..),
+  Value,
+  toBuiltin,
+ )
 import Test.QuickCheck (
   Arbitrary (arbitrary),
   Gen,
@@ -76,7 +76,7 @@ genUserCredential = PubKeyCredential . PubKeyHash . toBuiltin <$> genHashByteStr
 
 -- | Random script credential.
 genScriptCredential :: Gen Credential
-genScriptCredential = ScriptCredential . ValidatorHash . toBuiltin <$> genHashByteString
+genScriptCredential = ScriptCredential . ScriptHash . toBuiltin <$> genHashByteString
 
 -- | Random credential: combination of user and script credential generators.
 genCredential :: Gen Credential

agora-specs/Property/Governor.hs

@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Redundant bracket" #-}
+
 {- |
 Module     : Property.Governor
 Maintainer : seungheon.ooh@gmail.com
@@ -7,216 +11,299 @@ Property model and tests for 'Governor' related functions
 -}
 module Property.Governor (props) where
 
-import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
+import Agora.Governor (
+  GovernorDatum (
+    GovernorDatum,
+    createProposalTimeRangeMaxWidth,
+    maximumCreatedProposalsPerStake,
+    nextProposalId,
+    proposalThresholds,
+    proposalTimings
+  ),
+  PGovernorDatum,
+  pisGovernorDatumValid,
+ )
 import Agora.Governor.Scripts (governorPolicy)
 import Agora.Proposal (
   ProposalId (ProposalId),
-  ProposalThresholds (ProposalThresholds),
+  ProposalThresholds (
+    ProposalThresholds
+  ),
  )
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (MaxTimeRangeWidth),
   ProposalTimingConfig (ProposalTimingConfig),
  )
-import Data.Default.Class (Default (def))
-import Data.Tagged (Tagged (Tagged), untag)
-import Data.Universe (Finite (..), Universe (..))
-import Plutarch.Api.V1 (PScriptContext)
+import Data.Default (def)
+import Data.Tagged (Tagged (Tagged))
+import Data.Universe (Universe)
+import Data.Universe.Class (Finite)
+import Generics.SOP.NP (NP (Nil, (:*)))
+import Optics (view)
+import Plutarch.Api.V2 (PScriptContext)
 import Plutarch.Builtin (pforgetData)
 import Plutarch.Context (
   MintingBuilder,
-  buildMintingUnsafe,
+  buildMinting',
   input,
   mint,
   output,
   script,
   withDatum,
   withMinting,
-  withOutRef,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  ScriptContext (scriptContextTxInfo),
-  TxInInfo (txInInfoOutRef),
-  TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
-  TxOut (txOutValue),
+import Plutarch.Evaluate (evalTerm)
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.Compile (mustCompile)
+import Plutarch.Script (Script)
+import Plutarch.Test.QuickCheck (
+  Equality (OnPEq),
+  Partiality (ByComplete),
+  TestableTerm (TestableTerm),
+  haskEquiv,
+  pconstantT,
+  shouldCrash,
+  shouldRun,
  )
-import PlutusLedgerApi.V1.Value (assetClassValue)
+import PlutusLedgerApi.V2 (ScriptContext)
 import Property.Generator (genInput, genOutput)
 import Sample.Shared (
-  govAssetClass,
-  govSymbol,
-  govValidatorHash,
+  deterministicTracingConfig,
   governor,
+  governorAssetClass,
+  governorScriptHash,
+  governorSymbol,
   gstUTXORef,
  )
-import Test.Tasty (TestTree)
-import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
-import Test.Tasty.QuickCheck (
+import Test.QuickCheck (
+  Arbitrary (arbitrary),
   Gen,
   Property,
+  arbitraryBoundedEnum,
+  checkCoverage,
   choose,
   chooseInteger,
+  cover,
+  forAll,
   listOf1,
-  testProperty,
  )
+import Test.Tasty (TestTree, adjustOption, testGroup)
+import Test.Tasty.QuickCheck (QuickCheckTests, testProperty)
 
 data GovernorDatumCases
   = ExecuteLE0
   | CreateLE0
+  | ToVotingLE0
   | VoteLE0
+  | CosignLE0
   | Correct
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Enum, Bounded)
+  deriving anyclass (Universe, Finite)
 
-instance Universe GovernorDatumCases where
-  universe =
-    [ ExecuteLE0
-    , CreateLE0
-    , VoteLE0
-    , Correct
-    ]
+instance Arbitrary GovernorDatumCases where
+  arbitrary = arbitraryBoundedEnum
 
-instance Finite GovernorDatumCases where
-  universeF = universe
-  cardinality = Tagged 6
-
-{- | Property that checks `governorDatumValid`.
- `governorDatumValid` determines if given governor datum is valid or not. This property
- ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum.
+{- | Property that checks `pisGovernorDatumValid` behaves as intended by
+     comparing it to a simple haskell implementation.
 -}
 governorDatumValidProperty :: Property
 governorDatumValidProperty =
-  classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
+  haskEquiv @('OnPEq) @('ByComplete)
+    isValidModelImpl
+    (TestableTerm pisGovernorDatumValid)
+    (genDatum :* Nil)
   where
-    classifier :: GovernorDatum -> GovernorDatumCases
-    classifier (proposalThresholds -> ProposalThresholds e c v)
-      | e < 0 = ExecuteLE0
-      | c < 0 = CreateLE0
-      | v < 0 = VoteLE0
-      | otherwise = Correct
-
-    expected :: GovernorDatum -> Maybe Bool
-    expected c = Just $ classifier c == Correct
-
-    gen :: GovernorDatumCases -> Gen GovernorDatum
-    gen c = do
-      thres <- genProposalThresholds c
-
-      let timing = ProposalTimingConfig 0 0 0 0
-      return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
+    genDatum :: Gen (TestableTerm PGovernorDatum)
+    genDatum = pconstantT <$> (arbitrary >>= genDatumForCase)
       where
-        taggedInteger p = Tagged <$> chooseInteger p
-        genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
-        genProposalThresholds c = do
-          let validGT = taggedInteger (0, 1000000000)
-          execute <- validGT
-          create <- validGT
-          vote <- validGT
-          le0 <- taggedInteger (-1000, -1)
+        genDatumForCase :: GovernorDatumCases -> Gen GovernorDatum
+        genDatumForCase c = do
+          thres <- genProposalThresholds c
 
-          case c of
-            ExecuteLE0 ->
-              -- execute < 0
-              return $ ProposalThresholds le0 create vote
-            CreateLE0 ->
-              -- c < 0
-              return $ ProposalThresholds execute le0 vote
-            VoteLE0 ->
-              -- vote < 0
-              return $ ProposalThresholds execute create le0
-            Correct -> do
-              -- c <= vote < execute
-              nv <- taggedInteger (0, untag execute - 1)
-              nc <- taggedInteger (0, untag nv)
-              return $ ProposalThresholds execute nc nv
+          let timing = ProposalTimingConfig 0 0 0 0 0 0
+          pure $
+            GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
+          where
+            taggedInteger p = Tagged <$> chooseInteger p
+            genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
+            genProposalThresholds c = do
+              let validGT = taggedInteger (0, 1000000000)
+              execute <- validGT
+              create <- validGT
+              toVoting <- validGT
+              vote <- validGT
+              cosign <- validGT
+              le0 <- taggedInteger (-1000, -1)
+
+              case c of
+                ExecuteLE0 ->
+                  -- execute < 0
+                  return $ ProposalThresholds le0 create toVoting vote cosign
+                CreateLE0 ->
+                  -- c < 0
+                  return $ ProposalThresholds execute le0 toVoting vote cosign
+                ToVotingLE0 ->
+                  return $ ProposalThresholds execute create le0 vote cosign
+                VoteLE0 ->
+                  -- vote < 0
+                  return $ ProposalThresholds execute create toVoting le0 cosign
+                CosignLE0 ->
+                  return $ ProposalThresholds execute create toVoting vote le0
+                Correct ->
+                  return $ ProposalThresholds execute create toVoting vote cosign
+
+    -- \| This is a model Haskell implementation of `pisGovernorDatumValid`.
+    isValidModelImpl :: GovernorDatum -> Bool
+    isValidModelImpl = correctCase . classifier
+      where
+        correctCase = \case
+          Correct -> True
+          _ -> False
+
+        classifier :: GovernorDatum -> GovernorDatumCases
+        classifier
+          ( view #proposalThresholds ->
+              ProposalThresholds
+                execute
+                create
+                toVoting
+                vote
+                cosign
+            )
+            | execute < 0 = ExecuteLE0
+            | create < 0 = CreateLE0
+            | toVoting < 0 = ToVotingLE0
+            | vote < 0 = VoteLE0
+            | cosign < 0 = CosignLE0
+            | otherwise = Correct
+
+--------------------------------------------------------------------------------
 
 data GovernorPolicyCases
   = ReferenceUTXONotSpent
   | IncorrectAmountOfTokenMinted
   | GovernorOutputNotFound
-  | GovernorPolicyCorrect
   deriving stock (Eq, Show)
 
-instance Universe GovernorPolicyCases where
-  universe =
-    [ ReferenceUTXONotSpent
-    , IncorrectAmountOfTokenMinted
-    , GovernorOutputNotFound
-    , GovernorPolicyCorrect
-    ]
+governorMintingPolicyTests :: [TestTree]
+governorMintingPolicyTests =
+  [ mkGovMintingCasePropertyTest
+      "Reference input spend test"
+      ReferenceUTXONotSpent
+      "Spent"
+      "Not spent"
+  , mkGovMintingCasePropertyTest
+      "Amount of token minted test"
+      IncorrectAmountOfTokenMinted
+      "Correct"
+      "Incorrect"
+  , mkGovMintingCasePropertyTest
+      "Governor output presense"
+      GovernorOutputNotFound
+      "Present"
+      "Absent"
+  ]
 
-instance Finite GovernorPolicyCases where
-  universeF = universe
-  cardinality = Tagged 4
+{- | Creates a property by compiling governorPolicy script with given arguments
+   and checking if it runs as expected by a test.
+-}
+governorPolicyValid :: ScriptContext -> Bool -> Property
+governorPolicyValid ctx shouldSucceed =
+  let mp = mkPolicyScript ctx in if shouldSucceed then shouldRun mp else shouldCrash mp
 
-governorMintingProperty :: Property
-governorMintingProperty =
-  classifiedPropertyNative gen (const []) expected classifier actual
+{-# INLINEABLE mkPolicyScript #-}
+mkPolicyScript :: ScriptContext -> Script
+mkPolicyScript ctx = mustCompile (go # pconstant ctx)
   where
-    {- Note:
-    I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function.
-    -}
-    gst = assetClassValue govAssetClass 1
-    mintAmount x = mint . mconcat $ replicate x gst
-    outputToGov =
-      output $
-        mconcat
-          [ script govValidatorHash
-          , withValue gst
-          , withDatum govDatum
-          ]
-    referencedInput = input $ withOutRef gstUTXORef
+    go :: forall (s :: S). Term s (PScriptContext :--> POpaque)
+    go = loudEval $
+      plam $ \sc ->
+        governorPolicy
+          # pdata (pconstant (view #gstOutRef governor))
+          # pforgetData (pconstantData ())
+          # sc
 
-    govDatum :: GovernorDatum
-    govDatum =
-      GovernorDatum
-        { proposalThresholds = def
-        , nextProposalId = ProposalId 0
-        , proposalTimings = def
-        , createProposalTimeRangeMaxWidth = def
-        , maximumProposalsPerStake = 3
-        }
-
-    gen :: GovernorPolicyCases -> Gen ScriptContext
+-- | Prepares a minting policy test for given policy error case.
+mkGovMintingCasePropertyTest ::
+  String ->
+  GovernorPolicyCases ->
+  String ->
+  String ->
+  TestTree
+mkGovMintingCasePropertyTest name case' positiveCaseName negativeCaseName =
+  testProperty name $
+    forAll (gen case') $
+      \(ctx, valid) ->
+        checkCoverage $
+          cover 48 valid positiveCaseName $
+            cover 48 (not valid) negativeCaseName $
+              governorPolicyValid ctx valid
+  where
+    gen :: GovernorPolicyCases -> Gen (ScriptContext, Bool)
     gen c = do
       inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder
       outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder
       toks <- choose (2, 100)
 
+      valid <- arbitrary
       let comp =
-            case c of
-              ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
-              IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks
-              GovernorOutputNotFound -> referencedInput <> mintAmount 1
-              GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1
+            if valid
+              then referencedInput <> outputToGov <> mintAmount 1
+              else case c of
+                ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
+                IncorrectAmountOfTokenMinted ->
+                  referencedInput
+                    <> outputToGov
+                    <> mintAmount toks
+                GovernorOutputNotFound -> referencedInput <> mintAmount 1
 
-      return . buildMintingUnsafe $ inputs <> outputs <> comp <> withMinting govSymbol
-
-    expected :: ScriptContext -> Maybe ()
-    expected sc =
-      case classifier sc of
-        GovernorPolicyCorrect -> Just ()
-        _ -> Nothing
-
-    opaqueToUnit :: Term s (POpaque :--> PUnit)
-    opaqueToUnit = plam $ \_ -> pconstant ()
-
-    actual :: Term s (PScriptContext :--> PUnit)
-    actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor.gstOutRef # pforgetData (pconstantData ()) # sc
-
-    classifier :: ScriptContext -> GovernorPolicyCases
-    classifier sc
-      | minted /= gst = IncorrectAmountOfTokenMinted
-      | refInputNotExists = ReferenceUTXONotSpent
-      | govOutputNotExists = GovernorOutputNotFound
-      | otherwise = GovernorPolicyCorrect
+      let ctx =
+            buildMinting' $
+              inputs
+                <> outputs
+                <> comp
+                <> withMinting
+                  governorSymbol
+      pure (ctx, valid)
       where
-        txinfo = scriptContextTxInfo sc
-        minted = txInfoMint txinfo
-        refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
-        govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
+        govDatum :: GovernorDatum
+        govDatum =
+          GovernorDatum
+            { proposalThresholds = def
+            , nextProposalId = ProposalId 0
+            , proposalTimings = def
+            , createProposalTimeRangeMaxWidth = def
+            , maximumCreatedProposalsPerStake = 3
+            }
+
+        gst = assetClassValue governorAssetClass 1
+        mintAmount x = mint . mconcat $ replicate x gst
+        referencedInput = input $ withRef gstUTXORef
+        outputToGov =
+          output $
+            mconcat
+              [ script governorScriptHash
+              , withValue gst
+              , withDatum govDatum
+              ]
 
 props :: [TestTree]
 props =
-  [ testProperty "governorDatumValid" governorDatumValidProperty
-  , testProperty "governorPolicy" governorMintingProperty
+  [ adjustOption go . testProperty "governorDatumValid" $ governorDatumValidProperty
+  , testGroup "governorPolicy" governorMintingPolicyTests
   ]
+  where
+    go :: QuickCheckTests -> QuickCheckTests
+    go = max 20_000
+
+loudEval ::
+  forall (p :: S -> Type).
+  ClosedTerm p ->
+  ClosedTerm p
+loudEval x =
+  case evalTerm deterministicTracingConfig x of
+    Right (Right t, _, _) -> t
+    Right (Left err, _, trace) -> error $ show err <> show trace
+    Left err -> error $ show err

agora-specs/Property/Utils.hs

@@ -0,0 +1,37 @@
+module Property.Utils (props) where
+
+import Agora.Utils (phashDatum)
+import Generics.SOP (NP (Nil, (:*)))
+import Plutarch.Api.V2 (datumHash)
+import Plutarch.Test.QuickCheck (
+  Equality (OnPEq),
+  Partiality (ByComplete),
+  TestableTerm (TestableTerm),
+  arbitraryPLift,
+  haskEquiv,
+ )
+import Plutarch.Test.QuickCheck.Instances ()
+import Test.Tasty (TestTree, adjustOption)
+import Test.Tasty.QuickCheck (
+  Property,
+  QuickCheckTests,
+  resize,
+  testProperty,
+ )
+
+propHashDatumCorrect :: Property
+propHashDatumCorrect =
+  haskEquiv
+    @'OnPEq
+    @'ByComplete
+    datumHash
+    (TestableTerm phashDatum)
+    (resize 5 arbitraryPLift :* Nil)
+
+props :: [TestTree]
+props =
+  [ adjustOption go $ testProperty "Correct 'phashDatum'" propHashDatumCorrect
+  ]
+  where
+    go :: QuickCheckTests -> QuickCheckTests
+    go = max 20_000

agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs

@@ -0,0 +1,66 @@
+module Sample.AuthorityToken.UnauthorizedMintingExploit (
+  Parameters (..),
+  exploit,
+  mkTestCase,
+) where
+
+import Control.Exception (assert)
+import Plutarch.Context (input, mint, normalizeValue, output, script, withValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Value qualified as Value
+import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda)
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
+
+data Parameters = Parameters
+  { burntGAT :: Int
+  , mintedGAT :: Int
+  }
+
+exploit ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+exploit (Parameters burntGAT mintedGAT) =
+  assert (burntGAT > mintedGAT && mintedGAT > 0) $
+    effectInputBuilder <> maliciousGATOutputBuilder
+  where
+    (effectScriptHashes, rest) = splitAt burntGAT validatorHashes
+    maliciousScripts = take mintedGAT rest
+
+    gatValue hash =
+      Value.singleton
+        authorityTokenSymbol
+        (scriptHashToTokenName hash)
+
+    mkGATUTxO hash =
+      mconcat
+        [ script hash
+        , withValue $ normalizeValue $ minAda <> gatValue hash 1
+        ]
+
+    effectInputBuilder =
+      foldMap
+        ( \effectHash ->
+            mconcat
+              [ mint $ gatValue effectHash $ negate 1
+              , input $ mkGATUTxO effectHash
+              ]
+        )
+        effectScriptHashes
+
+    maliciousGATOutputBuilder =
+      foldMap
+        ( \scriptHash ->
+            mconcat
+              [ mint $ gatValue scriptHash 1
+              , output $ mkGATUTxO scriptHash
+              ]
+        )
+        maliciousScripts
+
+mkTestCase :: String -> Parameters -> SpecificationTree
+mkTestCase name ps =
+  testPolicy False name authorityTokenPolicy () $
+    mkMinting exploit ps authorityTokenSymbol

agora-specs/Sample/Effect/GovernorMutation.hs

@@ -2,7 +2,7 @@ module Sample.Effect.GovernorMutation (
   mkEffectTxInfo,
   effectValidator,
   effectValidatorAddress,
-  effectValidatorHash,
+  effectScriptHash,
   atAssetClass,
   govRef,
   effectRef,
@@ -13,74 +13,83 @@ module Sample.Effect.GovernorMutation (
 
 import Agora.Effect.GovernorMutation (
   MutateGovernorDatum (..),
-  mutateGovernorValidator,
  )
-import Agora.Governor (GovernorDatum (..))
+import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
 import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
-import Agora.Utils (validatorHashToTokenName)
+import Agora.SafeMoney (AuthorityTokenTag)
 import Data.Default.Class (Default (def))
+import Data.Map ((!))
 import Data.Tagged (Tagged (..))
-import Plutarch.Api.V1 (mkValidator, validatorHash)
-import PlutusLedgerApi.V1 (
+import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import Plutarch.Script (Script)
+import PlutusLedgerApi.V1 qualified as Interval (always)
+import PlutusLedgerApi.V1.Address (scriptHashAddress)
+import PlutusLedgerApi.V1.Value qualified as Value (
+  singleton,
+ )
+import PlutusLedgerApi.V2 (
   Address,
   Datum (..),
+  OutputDatum (OutputDatumHash),
+  ScriptHash,
+  ScriptPurpose (Spending),
   ToData (..),
   TxInInfo (..),
   TxInfo (..),
   TxOut (..),
   TxOutRef (TxOutRef),
-  Validator,
-  ValidatorHash (..),
- )
-import PlutusLedgerApi.V1 qualified as Interval (always)
-import PlutusLedgerApi.V1.Address (scriptHashAddress)
-import PlutusLedgerApi.V1.Value (AssetClass, assetClass)
-import PlutusLedgerApi.V1.Value qualified as Value (
-  assetClassValue,
-  singleton,
  )
+import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Shared (
   agoraScripts,
   authorityTokenSymbol,
-  deterministicTracingConfing,
-  govAssetClass,
-  govValidatorAddress,
+  governorAssetClass,
+  governorValidatorAddress,
   minAda,
+  mkRedeemer,
   signer,
  )
 import Test.Util (datumPair, toDatumHash)
 
 -- | The effect validator instance.
-effectValidator :: Validator
-effectValidator = mkValidator deterministicTracingConfing $ mutateGovernorValidator agoraScripts
+effectValidator :: Script
+effectValidator = agoraScripts ! "agora:mutateGovernorValidator"
 
 -- | The hash of the validator instance.
-effectValidatorHash :: ValidatorHash
-effectValidatorHash = validatorHash effectValidator
+effectScriptHash :: ScriptHash
+effectScriptHash = scriptHash effectValidator
 
 -- | The address of the validator.
 effectValidatorAddress :: Address
-effectValidatorAddress = scriptHashAddress effectValidatorHash
+effectValidatorAddress = scriptHashAddress effectScriptHash
 
 -- | The assetclass of the authority token.
-atAssetClass :: AssetClass
-atAssetClass = assetClass authorityTokenSymbol tokenName
+atAssetClass :: Tagged AuthorityTokenTag AssetClass
+atAssetClass = Tagged $ AssetClass authorityTokenSymbol tokenName
   where
-    tokenName = validatorHashToTokenName effectValidatorHash
+    tokenName = scriptHashToTokenName effectScriptHash
 
 -- | The mock reference of the governor state UTXO.
 govRef :: TxOutRef
-govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
+govRef =
+  TxOutRef
+    "d63fe09e6ac6e55dea82291149085d0a9b901df65087b83965188ee92fb25aef"
+    1
 
 -- | The mock reference of the effect UTXO.
 effectRef :: TxOutRef
-effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
+effectRef =
+  TxOutRef
+    "3ca6864670aae61a9f3e63064284cec00bd983d77cf4e1ab1e26bef34cafb0a9"
+    1
 
 -- | The input effect datum in 'mkEffectTransaction'.
-mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
-mkEffectDatum newGovDatum =
+mkEffectDatum :: GovernorDatum -> GovernorDatum -> MutateGovernorDatum
+mkEffectDatum oldGovDatum newGovDatum =
   MutateGovernorDatum
-    { governorRef = govRef
+    { oldDatum = oldGovDatum
     , newDatum = newGovDatum
     }
 
@@ -90,11 +99,11 @@ mkEffectDatum newGovDatum =
 -}
 mkEffectTxInfo :: GovernorDatum -> TxInfo
 mkEffectTxInfo newGovDatum =
-  let gst = Value.assetClassValue govAssetClass 1
-      at = Value.assetClassValue atAssetClass 1
+  let gst = assetClassValue governorAssetClass 1
+      at = assetClassValue atAssetClass 1
 
       -- One authority token is burnt in the process.
-      burnt = Value.assetClassValue atAssetClass (-1)
+      burnt = assetClassValue atAssetClass (-1)
 
       --
 
@@ -105,23 +114,24 @@ mkEffectTxInfo newGovDatum =
           , nextProposalId = ProposalId 0
           , proposalTimings = def
           , createProposalTimeRangeMaxWidth = def
-          , maximumProposalsPerStake = 3
+          , maximumCreatedProposalsPerStake = 3
           }
       governorInputDatum :: Datum
       governorInputDatum = Datum $ toBuiltinData governorInputDatum'
       governorInput :: TxOut
       governorInput =
         TxOut
-          { txOutAddress = govValidatorAddress
+          { txOutAddress = governorValidatorAddress
           , txOutValue = gst
-          , txOutDatumHash = Just $ toDatumHash governorInputDatum
+          , txOutDatum = OutputDatumHash $ toDatumHash governorInputDatum
+          , txOutReferenceScript = Nothing
           }
 
       --
 
       -- The effect should update 'nextProposalId'
       effectInputDatum' :: MutateGovernorDatum
-      effectInputDatum' = mkEffectDatum newGovDatum
+      effectInputDatum' = mkEffectDatum governorInputDatum' newGovDatum
       effectInputDatum :: Datum
       effectInputDatum = Datum $ toBuiltinData effectInputDatum'
       effectInput :: TxOut
@@ -129,7 +139,8 @@ mkEffectTxInfo newGovDatum =
         TxOut
           { txOutAddress = effectValidatorAddress
           , txOutValue = at -- The effect carry an authotity token.
-          , txOutDatumHash = Just $ toDatumHash effectInputDatum
+          , txOutDatum = OutputDatumHash $ toDatumHash effectInputDatum
+          , txOutReferenceScript = Nothing
           }
 
       --
@@ -141,23 +152,30 @@ mkEffectTxInfo newGovDatum =
       governorOutput :: TxOut
       governorOutput =
         TxOut
-          { txOutAddress = govValidatorAddress
+          { txOutAddress = governorValidatorAddress
           , txOutValue = mconcat [gst, minAda]
-          , txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          , txOutDatum = OutputDatumHash $ toDatumHash governorOutputDatum
+          , txOutReferenceScript = Nothing
           }
    in TxInfo
         { txInfoInputs =
             [ TxInInfo effectRef effectInput
             , TxInInfo govRef governorInput
             ]
+        , txInfoReferenceInputs = []
         , txInfoOutputs = [governorOutput]
         , txInfoFee = Value.singleton "" "" 2
         , txInfoMint = burnt
         , txInfoDCert = []
-        , txInfoWdrl = []
+        , txInfoWdrl = AssocMap.empty
         , txInfoValidRange = Interval.always
         , txInfoSignatories = [signer]
-        , txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
+        , txInfoData = AssocMap.fromList $ datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
+        , txInfoRedeemers =
+            AssocMap.fromList
+              [ (Spending effectRef, mkRedeemer ())
+              , (Spending govRef, mkRedeemer MutateGovernor)
+              ]
         , txInfoId = "74c75505691e7baa981fa80e50b9b7e88dbe1eda67d4f062d89d203b"
         }
 
@@ -168,7 +186,7 @@ validNewGovernorDatum =
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = 3
+    , maximumCreatedProposalsPerStake = 3
     }
 
 invalidNewGovernorDatum :: GovernorDatum
@@ -176,10 +194,10 @@ invalidNewGovernorDatum =
   GovernorDatum
     { proposalThresholds =
         def
-          { vote = Tagged (-1)
+          { toVoting = Tagged (-1)
           }
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = 3
+    , maximumCreatedProposalsPerStake = 3
     }

agora-specs/Sample/Effect/TreasuryWithdrawal.hs

@@ -6,170 +6,209 @@ Description: Sample based testing for Treasury Withdrawal Effect
 This module provides samples for Treasury Withdrawal Effect tests.
 -}
 module Sample.Effect.TreasuryWithdrawal (
-  inputTreasury,
-  inputUser,
-  inputGAT,
-  inputCollateral,
-  outputTreasury,
-  outputUser,
-  buildReceiversOutputFromDatum,
-  currSymbol,
-  users,
-  treasuries,
-  buildScriptContext,
+  runEffect,
+  Parameters (..),
+  Validity (..),
+  totallyValidParameters,
+  mkTestTree,
 ) where
 
 import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
-  treasuryWithdrawalValidator,
+  TreasuryWithdrawalDatum (..),
  )
-import Data.Default (def)
-import Plutarch.Api.V1 (mkValidator, validatorHash)
-import PlutusLedgerApi.V1 (
-  Address (Address),
+import Control.Composition ((.*))
+import Data.Foldable (Foldable (fold))
+import Data.List (singleton)
+import Data.Map ((!))
+import Data.Map.Ordered (OMap)
+import Data.Map.Ordered qualified as Map
+import Data.Semigroup (mtimesDefault)
+import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Context (credential, input, mint, output, script, withInlineDatum, withRef, withRefTxId, withValue)
+import Plutarch.Script (Script)
+import PlutusLedgerApi.V1.Value qualified as Value (scale, singleton)
+import PlutusLedgerApi.V2 (
   Credential (..),
-  CurrencySymbol,
-  DatumHash (DatumHash),
-  PubKeyHash,
-  ScriptContext (..),
-  ScriptPurpose (Spending),
-  TokenName (TokenName),
-  TxInInfo (TxInInfo),
-  TxInfo (
-    TxInfo,
-    txInfoDCert,
-    txInfoData,
-    txInfoFee,
-    txInfoId,
-    txInfoInputs,
-    txInfoMint,
-    txInfoOutputs,
-    txInfoSignatories,
-    txInfoValidRange,
-    txInfoWdrl
-  ),
-  TxOut (..),
+  TxId,
   TxOutRef (TxOutRef),
-  Validator,
-  ValidatorHash (ValidatorHash),
   Value,
  )
-import PlutusLedgerApi.V1.Interval qualified as Interval (always)
-import PlutusLedgerApi.V1.Value qualified as Value (singleton)
-import Test.Util (scriptCredentials, userCredentials)
+import PlutusLedgerApi.V3 (ScriptHash)
+import Sample.Shared (agoraScripts, authorityTokenPolicy, authorityTokenSymbol, minAda, signer, signer2, trScriptHash, trValidator)
+import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
+import Test.Util (CombinableBuilder, mkMinting, mkSpending, subtractValue, validatorHashes)
 
--- | A sample Currency Symbol.
-currSymbol :: CurrencySymbol
-currSymbol = "9c04a69c7133e26061fe5a15adaf4f79cd51e47ef22a2e3c91a36f04"
+data Parameters = Parameters
+  { shouldDeliver ::
+      OMap Credential Value
+  , treasuryInputCount :: Integer
+  , badReceivedValue :: Bool
+  , badReceivers :: Bool
+  , badReceiverOrder :: Bool
+  , badTreasuryPaybackValue :: Bool
+  }
 
--- | A sample 'PubKeyHash'.
-signer :: PubKeyHash
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+data Validity = Validity
+  { forGATPolicy :: Bool
+  , forEffectValidator :: Bool
+  , forTreasury :: Bool
+  }
 
--- | List of users who the effect will pay to.
-users :: [Credential]
-users = userCredentials
+effectValidator :: Script
+effectValidator = agoraScripts ! "agora:treasuryWithdrawalValidator"
 
--- | List of users who the effect will pay to.
-treasuries :: [Credential]
-treasuries = scriptCredentials
+effectHash :: ScriptHash
+effectHash = scriptHash effectValidator
 
-inputGAT :: TxInInfo
-inputGAT =
-  TxInInfo
-    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-    TxOut
-      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-      , txOutDatumHash = Just (DatumHash "")
-      }
-
--- | Create an input given the index of the treasury and the 'Value' at this input.
-inputTreasury :: Int -> Value -> TxInInfo
-inputTreasury indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (treasuries !! indx) Nothing
-      , txOutValue = val
-      , txOutDatumHash = Just (DatumHash "")
-      }
-
--- | Create a input given the index of the user and the 'Value' at this input.
-inputUser :: Int -> Value -> TxInInfo
-inputUser indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = val
-      , txOutDatumHash = Just (DatumHash "")
-      }
-
--- | Create a input representing the collateral given by a user.
-inputCollateral :: Int -> TxInInfo
-inputCollateral indx =
-  TxInInfo -- Initiator
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = Value.singleton "" "" 2000000
-      , txOutDatumHash = Just (DatumHash "")
-      }
-
--- | Create an output at the nth treasury with the given 'Value'.
-outputTreasury :: Int -> Value -> TxOut
-outputTreasury indx val =
-  TxOut
-    { txOutAddress = Address (treasuries !! indx) Nothing
-    , txOutValue = val
-    , txOutDatumHash = Nothing
+mkEffectDatum :: Parameters -> TreasuryWithdrawalDatum
+mkEffectDatum ps =
+  TreasuryWithdrawalDatum
+    { receivers = Map.assocs ps.shouldDeliver
+    , treasuries = [ScriptCredential trScriptHash]
     }
 
--- | Create an output at the nth user with the given 'Value'.
-outputUser :: Int -> Value -> TxOut
-outputUser indx val =
-  TxOut
-    { txOutAddress = Address (users !! indx) Nothing
-    , txOutValue = val
-    , txOutDatumHash = Nothing
+effectRef :: TxOutRef
+effectRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 0
+
+treasuryTxId :: TxId
+treasuryTxId = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15"
+
+mkEffectInputBuilder :: forall b. CombinableBuilder b => Parameters -> b
+mkEffectInputBuilder ps =
+  let mkGATValue = Value.singleton authorityTokenSymbol ""
+   in mconcat
+        [ mint $ mkGATValue (-1)
+        , input $
+            mconcat
+              [ script effectHash
+              , withRef effectRef
+              , withInlineDatum $ mkEffectDatum ps
+              , withValue $ mkGATValue 1
+              ]
+        ]
+
+mkTreasuryInputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryInputBuilder ps =
+  mtimesDefault ps.treasuryInputCount $
+    input $
+      mconcat
+        [ script trScriptHash
+        , withRefTxId treasuryTxId
+        , withInlineDatum ()
+        , withValue $ fold ps.shouldDeliver
+        ]
+
+mkTreasuryPaybackOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryPaybackOutputBuilder ps =
+  let sentAmount = fold ps.shouldDeliver
+      inputAmount =
+        flip Value.scale sentAmount $
+          if ps.badTreasuryPaybackValue
+            then 1
+            else ps.treasuryInputCount
+      paybackValue = inputAmount `subtractValue` sentAmount
+   in output $
+        mconcat
+          [ script trScriptHash
+          , withValue paybackValue
+          , withInlineDatum ()
+          ]
+
+mkReceiverOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkReceiverOutputBuilder ps =
+  let mkOutputValue =
+        (minAda <>)
+          . if ps.badReceivedValue
+            then const $ Value.singleton "" "bruh" 1
+            else id
+      mkFinalOutputs =
+        mconcat
+          . (if ps.badReceiverOrder then reverse else id)
+          . (if ps.badReceivers then drop 1 else id)
+      mkOutput :: _ -> _ -> b
+      mkOutput cred value =
+        output $
+          mconcat
+            [ credential cred
+            , withValue $ mkOutputValue value
+            , withInlineDatum ()
+            ]
+      rawOutputs =
+        foldMap (uncurry $ singleton .* mkOutput) $
+          Map.assocs ps.shouldDeliver
+   in mkFinalOutputs rawOutputs
+
+runEffect :: forall b. CombinableBuilder b => Parameters -> b
+runEffect ps =
+  foldMap
+    ($ ps)
+    [ mkEffectInputBuilder
+    , mkTreasuryInputBuilder
+    , mkReceiverOutputBuilder
+    , mkTreasuryPaybackOutputBuilder
+    ]
+
+totallyValidParameters :: Parameters
+totallyValidParameters =
+  Parameters
+    { shouldDeliver =
+        Map.fromList
+          [ (PubKeyCredential signer, Value.singleton "" "" 42_000_000)
+          , (PubKeyCredential signer2, Value.singleton "" "" 42_000_000)
+          , (ScriptCredential (head validatorHashes), Value.singleton "" "" 42_000_000)
+          ]
+    , treasuryInputCount = 2
+    , badReceivedValue = False
+    , badReceivers = False
+    , badReceiverOrder = False
+    , badTreasuryPaybackValue = False
     }
 
--- | Create a list of the outputs that are required as encoded in 'TreasuryWithdrawalDatum'.
-buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
-buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
+mkTestTree ::
+  String ->
+  Parameters ->
+  Validity ->
+  SpecificationTree
+mkTestTree name ps val =
+  group name [effect, treasury, authority]
   where
-    f x =
-      TxOut
-        { txOutAddress = Address (fst x) Nothing
-        , txOutValue = snd x
-        , txOutDatumHash = Nothing
-        }
+    spend = mkSpending runEffect ps
+    mint = mkMinting runEffect ps
 
--- | Effect validator instance.
-validator :: Validator
-validator = mkValidator def $ treasuryWithdrawalValidator currSymbol
+    effect =
+      testValidator
+        val.forEffectValidator
+        "effect"
+        effectValidator
+        (mkEffectDatum ps)
+        ()
+        (spend effectRef)
 
--- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
-validatorHashTN :: TokenName
-validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+    treasury =
+      testValidator
+        val.forTreasury
+        "treasury"
+        trValidator
+        ()
+        ()
+        (spend $ TxOutRef treasuryTxId 1)
 
-buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
-buildScriptContext inputs outputs =
-  ScriptContext
-    { scriptContextTxInfo =
-        TxInfo
-          { txInfoInputs = inputs
-          , txInfoOutputs = outputs
-          , txInfoFee = Value.singleton "" "" 2
-          , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
-          , txInfoDCert = []
-          , txInfoWdrl = []
-          , txInfoValidRange = Interval.always
-          , txInfoSignatories = [signer]
-          , txInfoData = []
-          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-          }
-    , scriptContextPurpose =
-        Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-    }
+    authority =
+      testPolicy
+        val.forGATPolicy
+        "authority"
+        authorityTokenPolicy
+        ()
+        (mint authorityTokenSymbol)

agora-specs/Sample/Governor/Initialize.hs

@@ -21,18 +21,18 @@ module Sample.Governor.Initialize (
 
 import Agora.Bootstrap (agoraScripts)
 import Agora.Governor (Governor (..), GovernorDatum (..))
+import Agora.Linker (linker)
 import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (MaxTimeRangeWidth),
   ProposalTimingConfig (ProposalTimingConfig),
  )
-import Agora.Scripts (
-  AgoraScripts (compiledGovernorPolicy),
-  governorSTAssetClass,
-  governorSTSymbol,
-  governorValidatorHash,
- )
 import Data.Default (Default (..))
+import Data.Map (Map, (!))
+import Data.Text (Text)
+import Optics (view)
+import Plutarch (Script)
+import Plutarch.Api.V2 (scriptHash)
 import Plutarch.Context (
   input,
   mint,
@@ -42,20 +42,23 @@ import Plutarch.Context (
   signedWith,
   txId,
   withDatum,
-  withOutRef,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  CurrencySymbol,
-  TxOutRef (TxOutRef),
-  ValidatorHash,
- )
 import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  CurrencySymbol (CurrencySymbol),
+  ScriptHash,
+  TxOutRef (TxOutRef),
+  getScriptHash,
+ )
 import Sample.Shared (
+  deterministicTracingConfig,
   minAda,
  )
 import Sample.Shared qualified as Shared
+import ScriptExport.ScriptInfo (runLinker)
 import Test.Specification (SpecificationTree, testPolicy)
 import Test.Util (CombinableBuilder, mkMinting, pubKeyHashes, sortValue)
 
@@ -65,19 +68,19 @@ data Parameters = Parameters
   -- ^ Whether the 'GovernorDatum.proposalThresholds' field of the output
   --    governor datum is valid or not.
   , datumMaxTimeRangeWidthValid :: Bool
-  -- ^ Whether the 'GovernorDatum.maximumProposalsPerStake'field of the
+  -- ^ Whether the 'GovernorDatum.maximumCreatedProposalsPerStake'field of the
   --    output governor datum is valid or not.
   , datumTimingConfigValid :: Bool
   -- ^ Whether the 'GovernorDatum.proposalTimings'field  of the output
   --    governor datum is valid or not.
   , withGovernorDatum :: Bool
-  , -- Whether the output GST UTxO will carry the governor datum.
-    presentWitness :: Bool
-  , -- Whether to spend the UTxO referenced by 'Governor.gstOutRef'.
-    mintMoreThanOneStateToken :: Bool
-  , -- More than one GST will be minted if this is set to true.
-    mintStateTokenWithName :: Bool
-    -- The token name of the GST won't be empty if this is set to true.
+  -- ^ Whether the output GST UTxO will carry the governor datum.
+  , presentWitness :: Bool
+  -- ^ Whether to spend the UTxO referenced by 'Governor.gstOutRef'.
+  , mintMoreThanOneStateToken :: Bool
+  -- ^ More than one GST will be minted if this is set to true.
+  , mintStateTokenWithName :: Bool
+  -- ^ The token name of the GST won't be empty if this is set to true.
   }
 
 --------------------------------------------------------------------------------
@@ -89,17 +92,17 @@ validGovernorOutputDatum =
     , nextProposalId = ProposalId 0
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = 3
+    , maximumCreatedProposalsPerStake = 3
     }
 
 invalidProposalThresholds :: ProposalThresholds
-invalidProposalThresholds = ProposalThresholds (-1) (-1) (-1)
+invalidProposalThresholds = ProposalThresholds (-1) (-1) (-1) (-1) (-1)
 
 invalidMaxTimeRangeWidth :: MaxTimeRangeWidth
 invalidMaxTimeRangeWidth = MaxTimeRangeWidth 0
 
 invalidProposalTimings :: ProposalTimingConfig
-invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1)
+invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1) (-1) (-1)
 
 witnessRef :: TxOutRef
 witnessRef = TxOutRef "b0353c22b0bd6c5296a8eef160ba25d90b5dc82a9bb8bdaa6823ffc19515d6ad" 0
@@ -110,17 +113,31 @@ governor =
     { gstOutRef = witnessRef
     }
 
-scripts :: AgoraScripts
-scripts = agoraScripts Shared.deterministicTracingConfing governor
+scripts :: Map Text Script
+scripts =
+  either
+    (error . show)
+    (fmap (view #script) . view #scripts)
+    ( runLinker
+        linker
+        (agoraScripts deterministicTracingConfig)
+        governor
+    )
 
-govAssetClass :: AssetClass
-govAssetClass = governorSTAssetClass scripts
+govPolicy :: Script
+govPolicy = scripts ! "agora:governorPolicy"
 
-govValidatorHash :: ValidatorHash
-govValidatorHash = governorValidatorHash scripts
+govValidator :: Script
+govValidator = scripts ! "agora:governorValidator"
 
 govSymbol :: CurrencySymbol
-govSymbol = governorSTSymbol scripts
+govSymbol = CurrencySymbol . getScriptHash $ scriptHash govPolicy
+
+govAssetClass :: AssetClass
+govAssetClass = AssetClass (govSymbol, "")
+
+govScriptHash :: ScriptHash
+govScriptHash = scriptHash govValidator
 
 --------------------------------------------------------------------------------
 
@@ -175,7 +192,7 @@ mintGST ps = builder
                 mconcat
                   [ pubKey witnessPubKey
                   , withValue witnessValue
-                  , withOutRef witnessRef
+                  , withRef witnessRef
                   ]
             , output $
                 mconcat
@@ -194,7 +211,7 @@ mintGST ps = builder
               else mempty
        in output $
             mconcat
-              [ script govValidatorHash
+              [ script govScriptHash
               , withValue governorValue
               , datum
               ]
@@ -274,6 +291,6 @@ mkTestCase name ps valid =
   testPolicy
     valid
     name
-    scripts.compiledGovernorPolicy
+    govPolicy
     ()
     (mkMinting mintGST ps govSymbol)

agora-specs/Sample/Governor/Mutate.hs

@@ -16,13 +16,13 @@ module Sample.Governor.Mutate (
   invalidBundles,
 ) where
 
-import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
 import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
-import Agora.Scripts (AgoraScripts (..))
-import Agora.Utils (validatorHashToTokenName)
 import Data.Default (def)
-import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash)
+import Data.Map ((!))
+import Data.Text qualified as T
+import Plutarch (Script)
+import Plutarch.Api.V2 (PMintingPolicy, scriptHash)
 import Plutarch.Context (
   input,
   mint,
@@ -30,26 +30,34 @@ import Plutarch.Context (
   pubKey,
   script,
   withDatum,
-  withOutRef,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
   Data,
+  ScriptHash,
   TxOutRef (TxOutRef),
-  ValidatorHash,
   Value,
   toData,
  )
-import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Shared (
   agoraScripts,
   authorityTokenSymbol,
-  govAssetClass,
-  govValidatorHash,
+  governorAssetClass,
+  governorScriptHash,
+  governorValidator,
   minAda,
  )
 import Test.Specification (SpecificationTree, testValidator)
-import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes)
+import Test.Util (
+  CombinableBuilder,
+  mkSpending,
+  pubKeyHashes,
+  sortValue,
+ )
 
 --------------------------------------------------------------------------------
 
@@ -96,7 +104,7 @@ governorInputDatum =
     , nextProposalId = ProposalId 0
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = 3
+    , maximumCreatedProposalsPerStake = 3
     }
 
 mkGovernorOutputDatum ::
@@ -106,14 +114,16 @@ mkGovernorOutputDatum DatumValid =
   Just $
     toData $
       governorInputDatum
-        { maximumProposalsPerStake = 4
+        { maximumCreatedProposalsPerStake = 4
         }
 mkGovernorOutputDatum ValueInvalid =
   let invalidProposalThresholds =
         ProposalThresholds
           { execute = -1
           , create = -1
+          , toVoting = -1
           , vote = -1
+          , cosign = -1
           }
    in Just $
         toData $
@@ -135,22 +145,22 @@ governorRedeemer = MutateGovernor
 
 mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
 mkGovernorBuilder ps =
-  let gst = Value.assetClassValue govAssetClass 1
+  let gst = assetClassValue governorAssetClass 1
       value = sortValue $ gst <> minAda
       gstOutput =
         if ps.stealGST
           then pubKey $ head pubKeyHashes
-          else script govValidatorHash
+          else script governorScriptHash
       withGSTDatum =
         maybe mempty withDatum $
           mkGovernorOutputDatum ps.governorOutputDatumValidity
    in mconcat
         [ input $
             mconcat
-              [ script govValidatorHash
+              [ script governorScriptHash
               , withDatum governorInputDatum
               , withValue value
-              , withOutRef governorRef
+              , withRef governorRef
               ]
         , output $
             mconcat
@@ -162,21 +172,28 @@ mkGovernorBuilder ps =
 
 --------------------------------------------------------------------------------
 
-mockEffectValidator :: ClosedTerm PValidator
-mockEffectValidator = noOpValidator authorityTokenSymbol
+mockEffectValidator :: Script
+mockEffectValidator = agoraScripts ! "agora:noOpValidator"
 
-mockEffectValidatorHash :: ValidatorHash
-mockEffectValidatorHash = validatorHash $ mkValidator def mockEffectValidator
+mockEffectScriptHash :: ScriptHash
+mockEffectScriptHash = scriptHash mockEffectValidator
+
+mockAuthScript :: ClosedTerm PMintingPolicy
+mockAuthScript = plam $ \_ _ -> popaque $ pcon PUnit
+
+mockAuthScriptHash :: ScriptHash
+mockAuthScriptHash =
+  scriptHash . either (error . T.unpack) id $ compile def mockAuthScript
 
 mkGATValue :: GATValidity -> Integer -> Value
 mkGATValue NoGAT _ = mempty
 mkGATValue v q =
-  let gatOwner = case v of
-        GATValid -> mockEffectValidatorHash
-        WrongTag -> head validatorHashes
+  let authScript = case v of
+        GATValid -> mockAuthScriptHash
+        WrongTag -> ""
    in Value.singleton
         authorityTokenSymbol
-        (validatorHashToTokenName gatOwner)
+        (scriptHashToTokenName authScript)
         q
 
 mkMockEffectBuilder :: forall b. CombinableBuilder b => MockEffectParameters -> b
@@ -192,12 +209,12 @@ mkMockEffectBuilder ps =
         [ mint burnt
         , input $
             mconcat
-              [ script mockEffectValidatorHash
+              [ script mockEffectScriptHash
               , withValue inputValue
               ]
         , output $
             mconcat
-              [ script mockEffectValidatorHash
+              [ script mockEffectScriptHash
               , withValue outputValue
               ]
         ]
@@ -219,7 +236,7 @@ mkTestCase name pb (Validity forGov) =
   testValidator
     forGov
     name
-    agoraScripts.compiledGovernorValidator
+    governorValidator
     governorInputDatum
     governorRedeemer
     (mkSpending mutate pb governorRef)

agora-specs/Sample/Proposal/Advance.hs

@@ -24,26 +24,31 @@ module Sample.Proposal.Advance (
   mkValidToNextStateBundle,
   mkValidToNextStateBundles,
   mkValidToFailedStateBundles,
+  mkValidToFinishedInlineGATDatumBundles,
   mkInsufficientVotesBundle,
   mkAmbiguousWinnerBundle,
   mkFromFinishedBundles,
   mkInsufficientCosignsBundle,
   mkToNextStateTooLateBundles,
-  mkInvalidOutputStakeBundles,
   mkMintGATsForWrongEffectsBundle,
   mkNoGATMintedBundle,
   mkGATsWithWrongDatumBundle,
   mkMintGATsWithoutTagBundle,
   mkBadGovernorOutputDatumBundle,
+  mkUnexpectedOutputStakeBundles,
+  mkFastforwardToFinishBundles,
+  mkBadGovernorRedeemerBundle,
 ) where
 
 import Agora.Governor (
   Governor (..),
   GovernorDatum (..),
-  GovernorRedeemer (MintGATs),
+  GovernorRedeemer (CreateProposal, MintGATs),
  )
 import Agora.Proposal (
   ProposalDatum (..),
+  ProposalEffectGroup,
+  ProposalEffectMetadata (ProposalEffectMetadata),
   ProposalId (ProposalId),
   ProposalRedeemer (AdvanceProposal),
   ProposalStatus (..),
@@ -61,57 +66,63 @@ import Agora.Proposal.Time (
     votingTime
   ),
  )
-import Agora.Scripts (AgoraScripts (..))
+import Agora.SafeMoney (AuthorityTokenTag, GTTag)
 import Agora.Stake (
   StakeDatum (..),
-  StakeRedeemer (WitnessStake),
  )
-import Agora.Utils (validatorHashToTokenName)
+import Control.Applicative (liftA2)
 import Control.Monad.State (execState, modify, when)
 import Data.Default (def)
-import Data.List (sort)
-import Data.Maybe (catMaybes, fromJust)
-import Data.Tagged (Tagged (..), untag)
+import Data.List (singleton, sort)
+import Data.Map.Strict qualified as StrictMap
+import Data.Maybe (fromJust)
+import Data.Tagged (Tagged (Tagged), untag)
 import Plutarch.Context (
   input,
   mint,
   output,
+  referenceInput,
   script,
   signedWith,
   timeRange,
   withDatum,
-  withOutRef,
+  withInlineDatum,
+  withRedeemer,
+  withRef,
   withValue,
  )
+import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
 import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
-import PlutusLedgerApi.V1 (
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
   DatumHash,
   POSIXTime,
   POSIXTimeRange,
   PubKeyHash,
+  ScriptHash,
   TxOutRef (TxOutRef),
-  ValidatorHash,
  )
-import PlutusLedgerApi.V1.Value (AssetClass (..))
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusTx.AssocMap qualified as AssocMap
+import PlutusTx qualified
 import Sample.Proposal.Shared (
   governorTxRef,
   proposalTxRef,
   stakeTxRef,
  )
 import Sample.Shared (
-  agoraScripts,
+  authorityTokenPolicy,
   authorityTokenSymbol,
-  govAssetClass,
-  govValidatorHash,
   governor,
+  governorAssetClass,
+  governorScriptHash,
+  governorValidator,
   minAda,
-  proposalPolicySymbol,
-  proposalValidatorHash,
+  proposalAssetClass,
+  proposalScriptHash,
+  proposalValidator,
   signer,
   stakeAssetClass,
-  stakeValidatorHash,
+  stakeScriptHash,
  )
 import Test.Specification (
   SpecificationTree,
@@ -127,9 +138,9 @@ import Test.Util (
   mkMinting,
   mkSpending,
   pubKeyHashes,
+  scriptHashes,
   sortValue,
   toDatum,
-  updateMap,
   validatorHashes,
  )
 
@@ -144,7 +155,7 @@ data ParameterBundle = ParameterBundle
   , governorParameters :: Maybe GovernorParameters
   -- ^ Parameters related to GST moving. If set to 'Nothing', the GST won't
   --   be moved, thus the governor validator won't be run in 'mkTestTree'.
-  , authorityTokenParameters :: Maybe AuthorityTokenParameters
+  , authorityTokenParameters :: [AuthorityTokenParameters]
   -- ^ Parameters related to GAT minting. If set to 'Nothing', no GAT will
   --     be minted, thus the GAT minting policy won't be run in 'mkTestTree'.
   , transactionTimeRange :: POSIXTimeRange
@@ -157,9 +168,18 @@ data ParameterBundle = ParameterBundle
   }
 
 -- | Everything about the generated governor stuff.
-newtype GovernorParameters = GovernorParameters
+data GovernorParameters = forall
+    (redeemer :: Type)
+    (predeemer :: PType).
+  ( PUnsafeLiftDecl predeemer
+  , PLifted predeemer ~ redeemer
+  , PIsData predeemer
+  , PlutusTx.ToData redeemer
+  ) =>
+  GovernorParameters
   { invalidGovernorOutputDatum :: Bool
   -- ^ The output governor datum will be changed.
+  , governorRedeemer :: redeemer
   }
 
 -- | Everything about the generated authority token stuff.
@@ -171,13 +191,17 @@ data AuthorityTokenParameters = forall
   , PIsData pdatum
   ) =>
   AuthorityTokenParameters
-  { mintGATsFor :: [ValidatorHash]
+  { mintGATsFor :: ScriptHash
   -- ^ GATs will be minted and sent to the given group of effects.
   , carryDatum :: Maybe datum
   -- ^ The datum that GAT UTxOs will be carrying.
+  , carryAuthScript :: Maybe ScriptHash
+  -- ^ The authentication script that GAT UTxOs link to through their token name.
   , invalidTokenName :: Bool
   -- ^ If set to true, GATs won't be tagged by their corresponding effect
   --    hashes.
+  , shouldInlineDatum :: Bool
+  -- ^ If set to true, the effect datum will be inlined.
   }
 
 -- | Represent the winning effect group(s).
@@ -193,7 +217,7 @@ data ProposalParameters = ProposalParameters
   -- ^ What status is the proposal advancing from
   , toStatus :: ProposalStatus
   -- ^ What status is the proposal advancing to
-  , effectList :: [AssocMap.Map ValidatorHash DatumHash]
+  , effectList :: [ProposalEffectGroup]
   -- ^ The effect groups of the proposal. A neutral effect group is not
   --    required here.
   , winnerAndVotes :: Maybe (Winner, Integer)
@@ -208,9 +232,8 @@ data ProposalParameters = ProposalParameters
 -- | Everything about the generated stake stuff.
 data StakeParameters = StakeParameters
   { numStake :: NumStake
-  , perStakeGTs :: Integer
+  , perStakeGTs :: Tagged GTTag Integer
   , transactionSignedByOwners :: Bool
-  , invalidStakeOutputDatum :: Bool
   }
 
 -- | Represent the number of stakes or the number of the cosigners.
@@ -219,7 +242,7 @@ type NumStake = Int
 -- | Represent an index.
 type Index = Int
 
-{- | The validity of the generated transacrion for variuos componets.
+{- | The validity of the generated transaction for variuos componets.
      'True' means valid, 'False' means invalid.
 -}
 data Validity = Validity
@@ -234,8 +257,8 @@ data Validity = Validity
 -- * Proposal
 
 -- | Mock cosigners.
-mkCosigners :: NumStake -> [PubKeyHash]
-mkCosigners = sort . flip take pubKeyHashes
+mkCosigners :: NumStake -> [Credential]
+mkCosigners = sort . fmap PubKeyCredential . flip take pubKeyHashes
 
 -- | Allocate the result tag for the effect at the given index.
 outcomeIdxToResultTag :: Index -> ResultTag
@@ -244,20 +267,20 @@ outcomeIdxToResultTag = ResultTag . fromIntegral
 -- | Add a neutral effect group and allocate result tags for the effect groups.
 mkEffects ::
   ProposalParameters ->
-  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  StrictMap.Map ResultTag ProposalEffectGroup
 mkEffects ps =
   let resultTags = map ResultTag [0 ..]
-      neutralEffect = AssocMap.empty
+      neutralEffect = StrictMap.empty
       finalEffects = ps.effectList <> [neutralEffect]
-   in AssocMap.fromList $ zip resultTags finalEffects
+   in StrictMap.fromList $ zip resultTags finalEffects
 
 -- | Set the votes of the winning group(s).
 setWinner :: (Winner, Integer) -> ProposalVotes -> ProposalVotes
 setWinner (All, votes) (ProposalVotes m) =
-  ProposalVotes $ AssocMap.mapMaybe (const $ Just votes) m
+  ProposalVotes $ StrictMap.mapMaybe (const $ Just votes) m
 setWinner (EffectAt winnerIdx, votes) (ProposalVotes m) =
   let winnerResultTag = outcomeIdxToResultTag winnerIdx
-   in ProposalVotes $ updateMap (const $ Just votes) winnerResultTag m
+   in ProposalVotes $ StrictMap.adjust (const votes) winnerResultTag m
 
 -- | Mock votes for the proposal, given the parameters.
 mkVotes ::
@@ -270,7 +293,7 @@ mkVotes ps =
 
 -- | The starting time of every generated proposal.
 proposalStartingTime :: POSIXTime
-proposalStartingTime = 0
+proposalStartingTime = 100
 
 -- | Create the input proposal datum given the parameters.
 mkProposalInputDatum :: ProposalParameters -> ProposalDatum
@@ -311,19 +334,19 @@ proposalRef = TxOutRef proposalTxRef 1
 -}
 mkProposalBuilder :: forall b. CombinableBuilder b => ProposalParameters -> b
 mkProposalBuilder ps =
-  let pst = Value.singleton proposalPolicySymbol "" 1
+  let pst = assetClassValue proposalAssetClass 1
       value = sortValue $ minAda <> pst
    in mconcat
         [ input $
             mconcat
-              [ script proposalValidatorHash
-              , withOutRef proposalRef
+              [ script proposalScriptHash
+              , withRef proposalRef
               , withDatum (mkProposalInputDatum ps)
               , withValue value
               ]
         , output $
             mconcat
-              [ script proposalValidatorHash
+              [ script proposalScriptHash
               , withDatum (mkProposalOutputDatum ps)
               , withValue value
               ]
@@ -340,7 +363,7 @@ proposalRedeemer = AdvanceProposal
 -- * Stake
 
 -- Mock owners of the stakes.
-mkStakeOwners :: NumStake -> [PubKeyHash]
+mkStakeOwners :: NumStake -> [Credential]
 mkStakeOwners = mkCosigners
 
 -- | Create the input stake datums given the parameters.
@@ -348,32 +371,14 @@ mkStakeInputDatums :: StakeParameters -> [StakeDatum]
 mkStakeInputDatums ps =
   let template =
         StakeDatum
-          { stakedAmount = Tagged ps.perStakeGTs
-          , owner = ""
+          { stakedAmount = ps.perStakeGTs
+          , owner = PubKeyCredential ""
           , delegatedTo = Nothing
           , lockedBy = []
           }
    in (\owner -> template {owner = owner})
         <$> mkStakeOwners ps.numStake
 
--- | Create the output stake datums given the parameters.
-mkStakeOutputDatums :: StakeParameters -> [StakeDatum]
-mkStakeOutputDatums ps =
-  let inputDatums = mkStakeInputDatums ps
-      outputStakedAmount =
-        Tagged $
-          if ps.invalidStakeOutputDatum
-            then ps.perStakeGTs * 10
-            else ps.perStakeGTs
-      modify inp = inp {stakedAmount = outputStakedAmount}
-   in modify <$> inputDatums
-
-{- | Get the input stake datum given the index. The range of the index is
-    @[0, 'StakeParameters.numStake - 1']@
--}
-getStakeInputDatumAt :: StakeParameters -> Index -> StakeDatum
-getStakeInputDatumAt ps = (!!) (mkStakeInputDatums ps)
-
 -- | Create the reference to a particular stake UTXO.
 mkStakeRef :: Index -> TxOutRef
 mkStakeRef = TxOutRef stakeTxRef . (+ 3) . fromIntegral
@@ -386,43 +391,30 @@ mkStakeBuilder ps =
   let perStakeValue =
         sortValue $
           minAda
-            <> Value.assetClassValue stakeAssetClass 1
-            <> Value.assetClassValue
-              (untag governor.gtClassRef)
+            <> assetClassValue stakeAssetClass 1
+            <> assetClassValue
+              governor.gtClassRef
               ps.perStakeGTs
-      perStake idx i o =
+      perStake idx i =
         let withSig =
-              if ps.transactionSignedByOwners
-                then signedWith i.owner
-                else mempty
+              case (i.owner, ps.transactionSignedByOwners) of
+                (PubKeyCredential owner, True) -> signedWith owner
+                _ -> mempty
          in mconcat
               [ withSig
-              , input $
+              , referenceInput $
                   mconcat
-                    [ script stakeValidatorHash
-                    , withOutRef (mkStakeRef idx)
+                    [ script stakeScriptHash
+                    , withRef (mkStakeRef idx)
                     , withValue perStakeValue
-                    , withDatum i
-                    ]
-              , output $
-                  mconcat
-                    [ script stakeValidatorHash
-                    , withValue perStakeValue
-                    , withDatum o
+                    , withInlineDatum i
                     ]
               ]
    in mconcat $
-        zipWith3
+        zipWith
           perStake
           [0 :: Index ..]
           (mkStakeInputDatums ps)
-          (mkStakeOutputDatums ps)
-
-{- | The proposal redeemer used to spend the stake UTXO, which is always
-      'WitnessStake' in this case.
--}
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = WitnessStake
 
 --------------------------------------------------------------------------------
 
@@ -436,14 +428,14 @@ governorInputDatum =
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = 3
+    , maximumCreatedProposalsPerStake = 3
     }
 
 -- | Create the output governor datum given the parameters.
 mkGovernorOutputDatum :: GovernorParameters -> GovernorDatum
 mkGovernorOutputDatum ps =
   if ps.invalidGovernorOutputDatum
-    then governorInputDatum {maximumProposalsPerStake = 15}
+    then governorInputDatum {maximumCreatedProposalsPerStake = 15}
     else governorInputDatum
 
 -- | Reference to the governor UTXO.
@@ -454,32 +446,27 @@ governorRef = TxOutRef governorTxRef 2
       governor validator.
 -}
 mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
-mkGovernorBuilder ps =
-  let gst = Value.assetClassValue govAssetClass 1
+mkGovernorBuilder ps@(GovernorParameters _ redeemer) =
+  let gst = assetClassValue governorAssetClass 1
       value = sortValue $ gst <> minAda
    in mconcat
         [ input $
             mconcat
-              [ script govValidatorHash
+              [ script governorScriptHash
               , withValue value
-              , withOutRef governorRef
+              , withRef governorRef
               , withDatum governorInputDatum
+              , withRedeemer redeemer
               ]
         , output $
             mconcat
-              [ script govValidatorHash
+              [ script governorScriptHash
               , withValue value
-              , withOutRef governorRef
+              , withRef governorRef
               , withDatum (mkGovernorOutputDatum ps)
               ]
         ]
 
-{- | The proposal redeemer used to spend the governor UTXO, which is always
-      'MintGATs' in this case.
--}
-governorRedeemer :: GovernorRedeemer
-governorRedeemer = MintGATs
-
 --------------------------------------------------------------------------------
 
 -- * Authority Token
@@ -492,27 +479,26 @@ mkAuthorityTokenBuilder ::
   CombinableBuilder b =>
   AuthorityTokenParameters ->
   b
-mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
-  foldMap perEffect es
-  where
-    perEffect :: ValidatorHash -> b
-    perEffect vh =
-      let tn =
-            if invalidTokenName
-              then ""
-              else validatorHashToTokenName vh
-          ac = AssetClass (authorityTokenSymbol, tn)
-          minted = Value.assetClassValue ac 1
-          value = sortValue $ minAda <> minted
-       in mconcat
-            [ mint minted
-            , output $
-                mconcat
-                  [ script vh
-                  , maybe mempty withDatum mdt
-                  , withValue value
-                  ]
-            ]
+mkAuthorityTokenBuilder ps@AuthorityTokenParameters {carryDatum, shouldInlineDatum} =
+  let tn =
+        case (ps.invalidTokenName, ps.carryAuthScript) of
+          (True, Just _) -> "deadbeef"
+          (True, Nothing) -> "deadbeef"
+          (False, Just as) -> scriptHashToTokenName as
+          (False, Nothing) -> ""
+      ac = Tagged @AuthorityTokenTag $ AssetClass authorityTokenSymbol tn
+      minted = assetClassValue ac 1
+      value = sortValue $ minAda <> minted
+      withDatum' = if shouldInlineDatum then withInlineDatum else withDatum
+   in mconcat
+        [ mint minted
+        , output $
+            mconcat
+              [ script ps.mintGATsFor
+              , maybe mempty withDatum' carryDatum
+              , withValue value
+              ]
+        ]
 
 -- | The redeemer used while running the authority token policy.
 authorityTokenRedeemer :: ()
@@ -532,7 +518,7 @@ advance pb =
         [ mkProposalBuilder pb.proposalParameters
         , mkStakeBuilder pb.stakeParameters
         , mkBuilderMaybe mkGovernorBuilder pb.governorParameters
-        , mkBuilderMaybe mkAuthorityTokenBuilder pb.authorityTokenParameters
+        , foldMap mkAuthorityTokenBuilder pb.authorityTokenParameters
         , timeRange pb.transactionTimeRange
         , maybe mempty signedWith pb.extraSignature
         ]
@@ -548,52 +534,48 @@ mkTestTree ::
   Validity ->
   SpecificationTree
 mkTestTree name pb val =
-  group name $ catMaybes [proposal, stake, governor, authority]
+  group name $ mconcat [proposal, governor, authority]
   where
     spend = mkSpending advance pb
-    mint = mkMinting advance pb
 
     proposal =
       let proposalInputDatum = mkProposalInputDatum pb.proposalParameters
-       in Just $
+       in singleton $
             testValidator
               val.forProposalValidator
               "proposal"
-              agoraScripts.compiledProposalValidator
+              proposalValidator
               proposalInputDatum
               proposalRedeemer
               (spend proposalRef)
 
-    stake =
-      let idx = 0
-       in Just $
-            testValidator
-              val.forStakeValidator
-              "stake"
-              agoraScripts.compiledStakeValidator
-              (getStakeInputDatumAt pb.stakeParameters idx)
-              stakeRedeemer
-              ( spend (mkStakeRef idx)
-              )
-
     governor =
-      testValidator
-        (fromJust val.forGovernorValidator)
-        "governor"
-        agoraScripts.compiledGovernorValidator
-        governorInputDatum
-        governorRedeemer
-        (spend governorRef)
-        <$ pb.governorParameters
+      maybe
+        []
+        ( singleton
+            . ( \(GovernorParameters _ governorRedeemer) ->
+                  testValidator
+                    (fromJust val.forGovernorValidator)
+                    "governor"
+                    governorValidator
+                    governorInputDatum
+                    governorRedeemer
+                    (spend governorRef)
+              )
+        )
+        (pb.governorParameters)
 
-    authority =
-      testPolicy
-        (fromJust val.forAuthorityTokenPolicy)
-        "authority"
-        agoraScripts.compiledAuthorityTokenPolicy
-        authorityTokenRedeemer
-        (mint authorityTokenSymbol)
-        <$ (pb.authorityTokenParameters)
+    authority = case pb.authorityTokenParameters of
+      [] -> []
+      _ ->
+        singleton
+          ( testPolicy
+              (fromJust val.forAuthorityTokenPolicy)
+              "authority"
+              authorityTokenPolicy
+              authorityTokenRedeemer
+              (mkMinting advance pb authorityTokenSymbol)
+          )
 
 {- | Create a test tree that runs a bunch of parameter bundles. These bundles
       should have the same validity.
@@ -651,7 +633,8 @@ mkInTimeTimeRange advanceFrom =
             + (def :: ProposalTimingConfig).draftTime
             + (def :: ProposalTimingConfig).votingTime
             + (def :: ProposalTimingConfig).lockingTime
-            + (def :: ProposalTimingConfig).executingTime - 1
+            + (def :: ProposalTimingConfig).executingTime
+            - 1
         )
     Finished -> error "Cannot advance 'Finished' proposal"
 
@@ -667,7 +650,8 @@ mkTooLateTimeRange advanceFrom =
         (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
         ( proposalStartingTime
             + (def :: ProposalTimingConfig).draftTime
-            + (def :: ProposalTimingConfig).votingTime - 1
+            + (def :: ProposalTimingConfig).votingTime
+            - 1
         )
     -- [S + D + V + L + 1, S + D + V + L + E -1]
     VotingReady ->
@@ -713,10 +697,12 @@ getNextState = \case
   Finished -> error "Cannot advance 'Finished' proposal"
 
 -- | Calculate the number of GTs per stake in order to exceed the minimum limit.
-compPerStakeGTsForDraft :: NumStake -> Integer
+compPerStakeGTsForDraft :: NumStake -> Tagged GTTag Integer
 compPerStakeGTsForDraft nCosigners =
-  untag (def :: ProposalThresholds).vote
-    `div` fromIntegral nCosigners + 1
+  Tagged $
+    untag (def :: ProposalThresholds).toVoting
+      `div` fromIntegral nCosigners
+      + 1
 
 dummyDatum :: ()
 dummyDatum = ()
@@ -725,29 +711,41 @@ dummyDatumHash :: DatumHash
 dummyDatumHash = datumHash $ toDatum dummyDatum
 
 -- | Create given number of effect groups. Each group will have 3 effects.
-mkMockEffects :: Int -> [AssocMap.Map ValidatorHash DatumHash]
-mkMockEffects =
-  flip
-    take
-    ( AssocMap.fromList
-        . flip zip (repeat dummyDatumHash)
-        <$> groupsOfN 3 validatorHashes
-    )
+mkMockEffects :: Bool -> Int -> [ProposalEffectGroup]
+mkMockEffects useAuthScript n = effects
+  where
+    effectsPerGroup = 3
 
-numberOfVotesThatExceedsTheMinimumRequirement :: Integer
-numberOfVotesThatExceedsTheMinimumRequirement =
-  untag (def @ProposalThresholds).execute + 1
+    mkAuthScripts True = Just <$> scriptHashes
+    mkAuthScripts False = repeat Nothing
+    authScripts = mkAuthScripts useAuthScript
+
+    datums = repeat dummyDatumHash
+
+    effectMetadata = zipWith ProposalEffectMetadata datums authScripts
+    effectScripts = validatorHashes
+
+    effects =
+      take n $
+        StrictMap.fromList
+          <$> groupsOfN
+            effectsPerGroup
+            (zip effectScripts effectMetadata)
+
+numberOfVotesThatJustMeetsTheMinimumRequirement :: Integer
+numberOfVotesThatJustMeetsTheMinimumRequirement =
+  untag (def @ProposalThresholds).execute
 
 mkWinnerVotes :: Index -> (Winner, Integer)
 mkWinnerVotes idx =
   ( EffectAt idx
-  , numberOfVotesThatExceedsTheMinimumRequirement
+  , numberOfVotesThatJustMeetsTheMinimumRequirement
   )
 
 ambiguousWinnerVotes :: (Winner, Integer)
 ambiguousWinnerVotes =
   ( All
-  , numberOfVotesThatExceedsTheMinimumRequirement
+  , numberOfVotesThatJustMeetsTheMinimumRequirement
   )
 
 --------------------------------------------------------------------------------
@@ -767,16 +765,18 @@ defaultWinnerIdx = 0
 mkValidToNextStateBundle ::
   -- | Number of cosigners.
   Word ->
-  -- | Number of effects
+  -- | Number of effects.
   Word ->
+  -- | Toggle the referenc script in GAT UTXO.
+  Bool ->
   -- | The initial proposal state, should not be 'Finished'.
   ProposalStatus ->
   ParameterBundle
-mkValidToNextStateBundle _ _ Finished =
+mkValidToNextStateBundle _ _ _ Finished =
   error "Cannot advance from Finished"
-mkValidToNextStateBundle nCosigners nEffects from =
+mkValidToNextStateBundle nCosigners nEffects authScript from =
   let next = getNextState from
-      effects = mkMockEffects $ fromIntegral nEffects
+      effects = mkMockEffects authScript $ fromIntegral nEffects
       winner = defaultWinnerIdx
 
       template =
@@ -792,15 +792,14 @@ mkValidToNextStateBundle nCosigners nEffects from =
                 }
           , stakeParameters =
               StakeParameters
-                { numStake = 1
+                { numStake = 0
                 , perStakeGTs =
                     compPerStakeGTsForDraft $
                       fromIntegral nCosigners
                 , transactionSignedByOwners = False
-                , invalidStakeOutputDatum = False
                 }
           , governorParameters = Nothing
-          , authorityTokenParameters = Nothing
+          , authorityTokenParameters = []
           , transactionTimeRange = mkInTimeTimeRange from
           , extraSignature = Just signer
           }
@@ -830,18 +829,26 @@ mkValidToNextStateBundle nCosigners nEffects from =
         when (from == Locked) $
           modify $ \b ->
             let aut =
-                  AuthorityTokenParameters
-                    { mintGATsFor = AssocMap.keys $ effects !! winner
-                    , carryDatum = Just dummyDatum
-                    , invalidTokenName = False
-                    }
+                  StrictMap.elems $
+                    StrictMap.mapWithKey
+                      ( \vh (ProposalEffectMetadata _ authScript) ->
+                          AuthorityTokenParameters
+                            { mintGATsFor = vh
+                            , carryDatum = Just dummyDatum
+                            , carryAuthScript = authScript
+                            , invalidTokenName = False
+                            , shouldInlineDatum = False
+                            }
+                      )
+                      (effects !! winner)
                 gov =
                   GovernorParameters
                     { invalidGovernorOutputDatum = False
+                    , governorRedeemer = MintGATs
                     }
              in b
                   { governorParameters = Just gov
-                  , authorityTokenParameters = Just aut
+                  , authorityTokenParameters = aut
                   }
    in execState modifyTemplate template
 
@@ -852,11 +859,34 @@ mkValidToNextStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToNextStateBundles nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects
-    <$> [ Draft
-        , VotingReady
-        , Locked
-        ]
+  liftA2
+    (mkValidToNextStateBundle nCosigners nEffects)
+    [True, False]
+    [Draft, VotingReady, Locked]
+
+mkValidToFinishedInlineGATDatumBundles ::
+  Word ->
+  Word ->
+  [ParameterBundle]
+mkValidToFinishedInlineGATDatumBundles nCosigners nEffects =
+  let templates =
+        liftA2
+          (mkValidToNextStateBundle nCosigners nEffects)
+          [True, False]
+          [Locked]
+
+      modifyTemplate template =
+        template
+          { authorityTokenParameters =
+              modifyAuthorityParameters
+                <$> template.authorityTokenParameters
+          }
+
+      modifyAuthorityParameters params =
+        params
+          { shouldInlineDatum = True
+          }
+   in modifyTemplate <$> templates
 
 mkValidToFailedStateBundles ::
   -- | Number of cosigners
@@ -865,15 +895,14 @@ mkValidToFailedStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToFailedStateBundles nCosigners nEffects =
-  mkBundle
-    <$> [ Draft
-        , VotingReady
-        , Locked
-        ]
+  liftA2
+    mkBundle
+    [True, False]
+    [Draft, VotingReady, Locked]
   where
-    mkBundle from =
+    mkBundle authScript from =
       let next = Finished
-          effects = mkMockEffects $ fromIntegral nEffects
+          effects = mkMockEffects authScript $ fromIntegral nEffects
        in ParameterBundle
             { proposalParameters =
                 ProposalParameters
@@ -886,15 +915,14 @@ mkValidToFailedStateBundles nCosigners nEffects =
                   }
             , stakeParameters =
                 StakeParameters
-                  { numStake = 1
+                  { numStake = 0
                   , perStakeGTs =
                       compPerStakeGTsForDraft $
                         fromIntegral nCosigners
                   , transactionSignedByOwners = False
-                  , invalidStakeOutputDatum = False
                   }
             , governorParameters = Nothing
-            , authorityTokenParameters = Nothing
+            , authorityTokenParameters = []
             , transactionTimeRange = mkTooLateTimeRange from
             , extraSignature = Just signer
             }
@@ -908,14 +936,13 @@ mkFromFinishedBundles ::
   Word ->
   [ParameterBundle]
 mkFromFinishedBundles nCosigners nEffects =
-  mkBundle
-    <$> [ Draft
-        , VotingReady
-        , Locked
-        ]
+  liftA2
+    mkBundle
+    [True, False]
+    [Draft, VotingReady, Locked]
   where
-    mkBundle from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+    mkBundle authScript from =
+      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
        in template
             { proposalParameters =
                 template.proposalParameters
@@ -926,28 +953,30 @@ mkFromFinishedBundles nCosigners nEffects =
 
 mkToNextStateTooLateBundles :: Word -> Word -> [ParameterBundle]
 mkToNextStateTooLateBundles nCosigners nEffects =
-  mkBundle
-    <$> [ Draft
-        , VotingReady
-        , Locked
-        ]
+  liftA2
+    mkBundle
+    [True, False]
+    [Draft, VotingReady, Locked]
   where
-    mkBundle from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+    mkBundle authScript from =
+      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
        in template
             { transactionTimeRange = mkTooLateTimeRange from
             }
 
-mkInvalidOutputStakeBundles :: Word -> Word -> [ParameterBundle]
-mkInvalidOutputStakeBundles nCosigners nEffects =
-  mkBundle <$> [Draft, VotingReady, Locked]
+mkUnexpectedOutputStakeBundles :: Word -> Word -> [ParameterBundle]
+mkUnexpectedOutputStakeBundles nCosigners nEffects =
+  liftA2
+    mkBundle
+    [True, False]
+    [VotingReady, Locked]
   where
-    mkBundle from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+    mkBundle authScript from =
+      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
        in template
             { stakeParameters =
                 template.stakeParameters
-                  { invalidStakeOutputDatum = True
+                  { numStake = 1
                   }
             }
 
@@ -963,9 +992,11 @@ mkInsufficientCosignsBundle nCosigners nEffects =
     }
   where
     insuffcientPerStakeGTs =
-      untag (def :: ProposalThresholds).vote
-        `div` fromIntegral nCosigners - 1
-    template = mkValidToNextStateBundle nCosigners nEffects Draft
+      Tagged $
+        untag (def :: ProposalThresholds).toVoting
+          `div` fromIntegral nCosigners
+          - 1
+    template = mkValidToNextStateBundle nCosigners nEffects False Draft
 
 -- * From VotingReady
 
@@ -986,7 +1017,7 @@ mkInsufficientVotesBundle ::
   Word ->
   ParameterBundle
 mkInsufficientVotesBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects VotingReady
+  mkValidToNextStateBundle nCosigners nEffects False VotingReady
     `setWinnerAndVotes` Nothing
 
 mkAmbiguousWinnerBundle ::
@@ -994,14 +1025,14 @@ mkAmbiguousWinnerBundle ::
   Word ->
   ParameterBundle
 mkAmbiguousWinnerBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects VotingReady
+  mkValidToNextStateBundle nCosigners nEffects False VotingReady
     `setWinnerAndVotes` Just ambiguousWinnerVotes
 
 -- * From Locked
 
 mkValidFromLockedBundle :: Word -> Word -> ParameterBundle
 mkValidFromLockedBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects Locked
+  mkValidToNextStateBundle nCosigners nEffects False Locked
 
 mkMintGATsForWrongEffectsBundle ::
   Word ->
@@ -1010,17 +1041,11 @@ mkMintGATsForWrongEffectsBundle ::
 mkMintGATsForWrongEffectsBundle nCosigners nEffects =
   template
     { authorityTokenParameters =
-        ( \aut ->
-            aut
-              { mintGATsFor =
-                  [ validatorHashes !! 1
-                  , validatorHashes !! 3
-                  , validatorHashes !! 5
-                  , validatorHashes !! 7
-                  ]
-              }
-        )
-          <$> template.authorityTokenParameters
+        take 4 $
+          zipWith
+            (\a i -> a {mintGATsFor = validatorHashes !! i})
+            template.authorityTokenParameters
+            [1, 3 ..]
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1031,7 +1056,7 @@ mkNoGATMintedBundle ::
   ParameterBundle
 mkNoGATMintedBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = Nothing
+    { authorityTokenParameters = []
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1059,16 +1084,20 @@ mkGATsWithWrongDatumBundle ::
   ParameterBundle
 mkGATsWithWrongDatumBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = Just newAut
+    { authorityTokenParameters = newAut
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
-    aut = fromJust template.authorityTokenParameters
     newAut =
-      AuthorityTokenParameters
-        aut.mintGATsFor
-        (Just (1 :: Integer))
-        False
+      ( \aut ->
+          AuthorityTokenParameters
+            aut.mintGATsFor
+            (Just (1 :: Integer))
+            aut.carryAuthScript
+            False
+            False
+      )
+        <$> template.authorityTokenParameters
 
 mkBadGovernorOutputDatumBundle ::
   Word ->
@@ -1080,4 +1109,47 @@ mkBadGovernorOutputDatumBundle nCosigners nEffects =
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
-    gov = GovernorParameters True
+    gov = GovernorParameters True MintGATs
+
+mkBadGovernorRedeemerBundle ::
+  Word ->
+  Word ->
+  ParameterBundle
+mkBadGovernorRedeemerBundle nCosigners nEffects =
+  template
+    { governorParameters = Just gov
+    }
+  where
+    template = mkValidFromLockedBundle nCosigners nEffects
+    gov = GovernorParameters False CreateProposal
+
+mkFastforwardToFinishBundles ::
+  Word ->
+  Word ->
+  [ParameterBundle]
+mkFastforwardToFinishBundles nCosigners nEffects = updateTemplate <$> templates
+  where
+    templates = mkValidToFailedStateBundles nCosigners nEffects
+    mkMaliciousTimRange =
+      let lb = proposalStartingTime - 1
+          dub =
+            1
+              + proposalStartingTime
+              + (def :: ProposalTimingConfig).draftTime
+          vub =
+            dub
+              + (def :: ProposalTimingConfig).votingTime
+              + (def :: ProposalTimingConfig).lockingTime
+          lub =
+            vub
+              + (def :: ProposalTimingConfig).executingTime
+          go Draft = (lb, dub)
+          go VotingReady = (lb, vub)
+          go Locked = (lb, lub)
+          go Finished = error "cannot advance from Finished"
+       in uncurry closedBoundedInterval . go
+    updateTemplate template =
+      template
+        { transactionTimeRange =
+            mkMaliciousTimRange template.proposalParameters.fromStatus
+        }

agora-specs/Sample/Proposal/Cosign.hs

@@ -6,12 +6,22 @@ Description: Generate sample data for testing the functionalities of cosigning p
 Sample and utilities for testing the functionalities of cosigning proposals.
 -}
 module Sample.Proposal.Cosign (
-  Parameters (..),
-  validCosignNParameters,
-  duplicateCosignersParameters,
-  statusNotDraftCosignNParameters,
-  invalidStakeOutputParameters,
+  StakedAmount (..),
+  StakeOwner (..),
+  StakeParameters (..),
+  SignedBy (..),
+  TransactionParameters (..),
+  ProposalParameters (..),
+  ParameterBundle (..),
+  Validity (..),
+  cosign,
   mkTestTree,
+  totallyValid,
+  insufficientStakedAmount,
+  duplicateCosigners,
+  locksNotUpdated,
+  cosignersNotUpdated,
+  cosignAfterDraft,
 ) where
 
 import Agora.Governor (Governor (..))
@@ -20,6 +30,7 @@ import Agora.Proposal (
   ProposalId (ProposalId),
   ProposalRedeemer (Cosign),
   ProposalStatus (..),
+  ProposalThresholds (..),
   ResultTag (ResultTag),
   emptyVotesFor,
  )
@@ -28,194 +39,272 @@ import Agora.Proposal.Time (
   ProposalTimingConfig (draftTime),
  )
 import Agora.SafeMoney (GTTag)
-import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
-  StakeDatum (StakeDatum, owner),
-  StakeRedeemer (WitnessStake),
-  stakedAmount,
+  ProposalAction (Cosigned, Created),
+  ProposalLock (ProposalLock),
+  StakeDatum (..),
+  StakeRedeemer (PermitVote),
  )
 import Data.Coerce (coerce)
 import Data.Default (def)
 import Data.List (sort)
-import Data.Tagged (Tagged, untag)
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged)
 import Plutarch.Context (
   input,
+  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
   txId,
   withDatum,
-  withOutRef,
-  withTxId,
+  withInlineDatum,
+  withRedeemer,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  POSIXTimeRange,
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
+  POSIXTime (POSIXTime),
   PubKeyHash,
-  TxOutRef (..),
-  Value,
+  TxOutRef (TxOutRef),
  )
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
 import Sample.Shared (
-  agoraScripts,
   governor,
   minAda,
-  proposalPolicySymbol,
-  proposalValidatorHash,
-  signer,
+  proposalAssetClass,
+  proposalScriptHash,
+  proposalValidator,
   stakeAssetClass,
-  stakeValidatorHash,
+  stakeScriptHash,
+  stakeValidator,
  )
 import Test.Specification (
   SpecificationTree,
   group,
   testValidator,
  )
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue)
+import Test.Util (
+  CombinableBuilder,
+  closedBoundedInterval,
+  mkSpending,
+  pubKeyHashes,
+ )
 
--- | Parameters for cosigning a proposal.
-data Parameters = Parameters
-  { newCosigners :: [PubKeyHash]
-  -- ^ New cosigners to be added, and the owners of the generated stakes.
-  , proposalStatus :: ProposalStatus
-  -- ^ Current state of the proposal.
-  , alterOutputStakes :: Bool
-  -- ^ Whether to generate invalid stake outputs.
-  --   In particular, the 'stakedAmount' of all the stake datums will be set to zero.
+data StakedAmount = Sufficient | Insufficient
+
+data StakeOwner = Creator | Other
+
+data StakeParameters = StakeParameters
+  { gtAmount :: StakedAmount
+  , stakeOwner :: StakeOwner
+  , dontUpdateLocks :: Bool
   }
 
--- | Owner of the creator stake, doesn't really matter in this case.
-proposalCreator :: PubKeyHash
-proposalCreator = signer
+data SignedBy = Owner | Delegatee | Unknown
 
--- | The amount of GTs every generated stake has, doesn't really matter in this case.
-perStakedGTs :: Tagged GTTag Integer
-perStakedGTs = 5
+newtype TransactionParameters = TransactionParameters
+  { signedBy :: SignedBy
+  }
 
-{- | Create input proposal datum given the parameters.
-   In particular, 'status' is set to 'proposalStstus'.
--}
-mkProposalInputDatum :: Parameters -> ProposalDatum
+data ProposalParameters = ProposalParameters
+  { proposalStatus :: ProposalStatus
+  , dontUpdateCosigners :: Bool
+  }
+
+-- | Parameters for cosigning a proposal.
+data ParameterBundle = ParameterBundle
+  { stakeParameters :: StakeParameters
+  , proposalParameters :: ProposalParameters
+  , transactionParameters :: TransactionParameters
+  }
+
+data Validity = Validity
+  { forProposalValidator :: Bool
+  , forStakeValidator :: Bool
+  }
+
+--------------------------------------------------------------------------------
+
+mkStakeAmount :: StakedAmount -> Tagged GTTag Integer
+mkStakeAmount Sufficient = (def @ProposalThresholds).cosign
+mkStakeAmount Insufficient = mkStakeAmount Sufficient - 1
+
+mkStakeOwner :: StakeOwner -> PubKeyHash
+mkStakeOwner Creator = creator
+mkStakeOwner Other = pubKeyHashes !! 2
+
+mkSigner :: StakeOwner -> SignedBy -> PubKeyHash
+mkSigner so Owner = mkStakeOwner so
+mkSigner _ Delegatee = delegatee
+mkSigner _ Unknown = pubKeyHashes !! 4
+
+creator :: PubKeyHash
+creator = pubKeyHashes !! 1
+
+delegatee :: PubKeyHash
+delegatee = pubKeyHashes !! 3
+
+--------------------------------------------------------------------------------
+
+defProposalId :: ProposalId
+defProposalId = ProposalId 0
+
+mkProposalInputDatum :: ParameterBundle -> ProposalDatum
 mkProposalInputDatum ps =
   let effects =
-        AssocMap.fromList
-          [ (ResultTag 0, AssocMap.empty)
-          , (ResultTag 1, AssocMap.empty)
+        StrictMap.fromList
+          [ (ResultTag 0, StrictMap.empty)
+          , (ResultTag 1, StrictMap.empty)
           ]
    in ProposalDatum
         { proposalId = ProposalId 0
         , effects = effects
-        , status = ps.proposalStatus
-        , cosigners = [proposalCreator]
+        , status = ps.proposalParameters.proposalStatus
+        , cosigners = [PubKeyCredential creator]
         , thresholds = def
         , votes = emptyVotesFor effects
         , timingConfig = def
         , startingTime = ProposalStartingTime 0
         }
 
-{- | Create the output proposal datum given the parameters.
-   The 'newCosigners' is added to the exisiting list of cosigners, note the said list should be sorted in
-     ascending order.
--}
-mkProposalOutputDatum :: Parameters -> ProposalDatum
+mkProposalOutputDatum :: ParameterBundle -> ProposalDatum
 mkProposalOutputDatum ps =
   let inputDatum = mkProposalInputDatum ps
-   in inputDatum
-        { cosigners = sort $ inputDatum.cosigners <> ps.newCosigners
+      stakeOwner =
+        PubKeyCredential $
+          mkStakeOwner ps.stakeParameters.stakeOwner
+      newCosigners =
+        if ps.proposalParameters.dontUpdateCosigners
+          then inputDatum.cosigners
+          else sort $ stakeOwner : inputDatum.cosigners
+   in inputDatum {cosigners = newCosigners}
+
+proposalRedeemer :: ProposalRedeemer
+proposalRedeemer = Cosign
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef proposalTxRef 1
+
+--------------------------------------------------------------------------------
+
+mkStakeInputDatum :: ParameterBundle -> StakeDatum
+mkStakeInputDatum ps =
+  let sps = ps.stakeParameters
+      amount = mkStakeAmount sps.gtAmount
+      owner = mkStakeOwner sps.stakeOwner
+      locks = case sps.stakeOwner of
+        Creator -> [ProposalLock defProposalId Created]
+        _ -> []
+   in StakeDatum
+        { stakedAmount = amount
+        , owner = PubKeyCredential owner
+        , delegatedTo = Just $ PubKeyCredential delegatee
+        , lockedBy = locks
         }
 
--- | Create all the input stakes given the parameters.
-mkStakeInputDatums :: Parameters -> [StakeDatum]
-mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk Nothing []) . newCosigners
+mkStakeOuputDatum :: ParameterBundle -> StakeDatum
+mkStakeOuputDatum ps =
+  let sps = ps.stakeParameters
+      inpDatum = mkStakeInputDatum ps
+      locks =
+        if sps.dontUpdateLocks
+          then inpDatum.lockedBy
+          else ProposalLock defProposalId Cosigned : inpDatum.lockedBy
+   in inpDatum {lockedBy = locks}
+
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = PermitVote
+
+stakeRef :: TxOutRef
+stakeRef = TxOutRef stakeTxRef 0
+
+--------------------------------------------------------------------------------
 
 -- | Create a 'TxInfo' that tries to cosign a proposal with new cosigners.
-cosign :: forall b. CombinableBuilder b => Parameters -> b
+cosign :: forall b. CombinableBuilder b => ParameterBundle -> b
 cosign ps = builder
   where
-    pst = Value.singleton proposalPolicySymbol "" 1
-    sst = Value.assetClassValue stakeAssetClass 1
+    pst = assetClassValue proposalAssetClass 1
+    sst = assetClassValue stakeAssetClass 1
 
-    ---
+    ----------------------------------------------------------------------------
 
-    stakeInputDatums :: [StakeDatum]
-    stakeInputDatums = mkStakeInputDatums ps
+    stakeInputDatum = mkStakeInputDatum ps
+    stakeOutputDatum = mkStakeOuputDatum ps
 
-    stakeValue :: Value
     stakeValue =
-      sortValue $
+      normalizeValue $
         minAda
-          <> Value.assetClassValue
-            (untag governor.gtClassRef)
-            (untag perStakedGTs)
+          <> assetClassValue
+            governor.gtClassRef
+            (mkStakeAmount ps.stakeParameters.gtAmount)
           <> sst
 
     stakeBuilder =
-      foldMap
-        ( \(stakeDatum, refIdx) ->
-            let stakeOutputDatum =
-                  if ps.alterOutputStakes
-                    then stakeDatum {stakedAmount = 0}
-                    else stakeDatum
-             in mconcat
-                  [ input $
-                      mconcat
-                        [ script stakeValidatorHash
-                        , withValue stakeValue
-                        , withDatum stakeDatum
-                        , withTxId stakeTxRef
-                        , withOutRef (mkStakeRef refIdx)
-                        ]
-                  , output $
-                      mconcat
-                        [ script stakeValidatorHash
-                        , withValue stakeValue
-                        , withDatum stakeOutputDatum
-                        ]
-                  , signedWith stakeDatum.owner
-                  ]
-        )
-        $ zip
-          stakeInputDatums
-          [0 ..]
+      mconcat
+        [ input $
+            mconcat
+              [ script stakeScriptHash
+              , withValue stakeValue
+              , withInlineDatum stakeInputDatum
+              , withRef stakeRef
+              , withRedeemer stakeRedeemer
+              ]
+        , output $
+            mconcat
+              [ script stakeScriptHash
+              , withValue stakeValue
+              , withInlineDatum stakeOutputDatum
+              ]
+        ]
 
-    ---
+    ----------------------------------------------------------------------------
 
-    proposalInputDatum :: ProposalDatum
     proposalInputDatum = mkProposalInputDatum ps
-
-    proposalOutputDatum :: ProposalDatum
     proposalOutputDatum = mkProposalOutputDatum ps
 
+    proposalValue =
+      normalizeValue $
+        pst <> minAda
+
     proposalBuilder =
       mconcat
         [ input $
             mconcat
-              [ script proposalValidatorHash
-              , withValue pst
+              [ script proposalScriptHash
+              , withValue proposalValue
               , withDatum proposalInputDatum
-              , withTxId proposalTxRef
-              , withOutRef proposalRef
+              , withRef proposalRef
+              , withRedeemer proposalRedeemer
               ]
         , output $
             mconcat
-              [ script proposalValidatorHash
-              , withValue (sortValue (pst <> minAda))
+              [ script proposalScriptHash
+              , withValue proposalValue
               , withDatum proposalOutputDatum
               ]
         ]
 
-    validTimeRange :: POSIXTimeRange
+    ----------------------------------------------------------------------------
+
     validTimeRange =
       closedBoundedInterval
         (coerce proposalInputDatum.startingTime + 1)
         ( coerce proposalInputDatum.startingTime
-            + proposalInputDatum.timingConfig.draftTime - 1
+            + proposalInputDatum.timingConfig.draftTime
+            - 1
         )
 
-    ---
+    sig =
+      mkSigner
+        ps.stakeParameters.stakeOwner
+        ps.transactionParameters.signedBy
+
+    ----------------------------------------------------------------------------
 
     builder =
       mconcat
@@ -223,117 +312,107 @@ cosign ps = builder
         , timeRange validTimeRange
         , proposalBuilder
         , stakeBuilder
+        , signedWith sig
         ]
 
--- | Reference index of the proposal UTXO.
-proposalRefIdx :: Integer
-proposalRefIdx = 1
+--------------------------------------------------------------------------------
 
--- | Spend the proposal ST.
-proposalRef :: TxOutRef
-proposalRef = TxOutRef proposalTxRef proposalRefIdx
-
--- | Consume the given stake.
-mkStakeRef :: Int -> TxOutRef
-mkStakeRef idx =
-  TxOutRef
-    stakeTxRef
-    $ proposalRefIdx + 1 + fromIntegral idx
-
--- | Create a proposal redeemer which cosigns with the new cosginers.
-mkProposalRedeemer :: Parameters -> ProposalRedeemer
-mkProposalRedeemer (sort . newCosigners -> cs) = Cosign cs
-
--- | Stake redeemer for cosuming all the stakes generated in the module.
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = WitnessStake
-
----
-
--- | Create a valid parameters that cosign the proposal with a given number of cosigners.
-validCosignNParameters :: Int -> Parameters
-validCosignNParameters n
-  | n > 0 =
-      Parameters
-        { newCosigners = take n pubKeyHashes
-        , proposalStatus = Draft
-        , alterOutputStakes = False
-        }
-  | otherwise = error "Number of cosigners should be positive"
-
----
-
-{- | Parameters that make 'cosign' yield duplicate cosigners.
-   Invalid for the ptoposal validator, perfectly valid for stake validator.
--}
-duplicateCosignersParameters :: Parameters
-duplicateCosignersParameters =
-  Parameters
-    { newCosigners = [proposalCreator]
-    , proposalStatus = Draft
-    , alterOutputStakes = False
-    }
-
----
-
-{- | Generate a list of parameters that sets proposal status to something other than 'Draft'.
-   Invalid for the ptoposal validator, perfectly valid for stake validator.
--}
-statusNotDraftCosignNParameters :: Int -> [Parameters]
-statusNotDraftCosignNParameters n =
-  map
-    ( \st ->
-        Parameters
-          { newCosigners = take n pubKeyHashes
-          , proposalStatus = st
-          , alterOutputStakes = False
-          }
-    )
-    [VotingReady, Locked, Finished]
-
----
-
-{- | Parameters thet change the output stake datums.
-   Invalid for both proposal validator and stake validator.
--}
-invalidStakeOutputParameters :: Parameters
-invalidStakeOutputParameters =
-  (validCosignNParameters 2)
-    { alterOutputStakes = True
-    }
-
----
-
--- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run.
 mkTestTree ::
-  -- | The name of the test group.
   String ->
-  Parameters ->
-  -- | Are the parameters valid for the proposal validator?
-  Bool ->
+  ParameterBundle ->
+  Validity ->
   SpecificationTree
-mkTestTree name ps isValid = group name [proposal, stake]
+mkTestTree name ps val =
+  group name [proposal, stake]
   where
     spend = mkSpending cosign ps
 
     proposal =
-      let proposalInputDatum = mkProposalInputDatum ps
-       in testValidator
-            isValid
-            "proposal"
-            agoraScripts.compiledProposalValidator
-            proposalInputDatum
-            (mkProposalRedeemer ps)
-            (spend proposalRef)
+      testValidator
+        val.forProposalValidator
+        "proposal"
+        proposalValidator
+        (mkProposalInputDatum ps)
+        proposalRedeemer
+        (spend proposalRef)
 
     stake =
-      let idx = 0
-          stakeInputDatum = mkStakeInputDatums ps !! idx
-          isValid = not ps.alterOutputStakes
-       in testValidator
-            isValid
-            "stake"
-            agoraScripts.compiledStakeValidator
-            stakeInputDatum
-            stakeRedeemer
-            (spend $ mkStakeRef idx)
+      testValidator
+        val.forStakeValidator
+        "stake"
+        stakeValidator
+        (mkStakeInputDatum ps)
+        stakeRedeemer
+        (spend stakeRef)
+
+--------------------------------------------------------------------------------
+
+totallyValid :: ParameterBundle
+totallyValid =
+  ParameterBundle
+    { stakeParameters =
+        StakeParameters
+          { gtAmount = Sufficient
+          , stakeOwner = Other
+          , dontUpdateLocks = False
+          }
+    , proposalParameters =
+        ProposalParameters
+          { proposalStatus = Draft
+          , dontUpdateCosigners = False
+          }
+    , transactionParameters =
+        TransactionParameters
+          { signedBy =
+              Owner
+          }
+    }
+
+insufficientStakedAmount :: ParameterBundle
+insufficientStakedAmount =
+  totallyValid
+    { stakeParameters =
+        totallyValid.stakeParameters
+          { gtAmount = Insufficient
+          }
+    }
+
+locksNotUpdated :: ParameterBundle
+locksNotUpdated =
+  totallyValid
+    { stakeParameters =
+        totallyValid.stakeParameters
+          { dontUpdateLocks = True
+          }
+    }
+
+duplicateCosigners :: ParameterBundle
+duplicateCosigners =
+  totallyValid
+    { stakeParameters =
+        totallyValid.stakeParameters
+          { stakeOwner = Creator
+          }
+    }
+
+cosignersNotUpdated :: ParameterBundle
+cosignersNotUpdated =
+  totallyValid
+    { proposalParameters =
+        totallyValid.proposalParameters
+          { dontUpdateCosigners = True
+          }
+    }
+
+cosignAfterDraft :: [ParameterBundle]
+cosignAfterDraft =
+  map
+    ( \s ->
+        totallyValid
+          { proposalParameters =
+              totallyValid.proposalParameters
+                { proposalStatus = s
+                }
+          }
+    )
+    [VotingReady, Locked, Finished]

agora-specs/Sample/Proposal/Create.hs

@@ -17,70 +17,99 @@ module Sample.Proposal.Create (
   timeRangeNotTightParameters,
   timeRangeNotClosedParameters,
   invalidProposalStatusParameters,
+  fakeSSTParameters,
+  wrongGovernorRedeemer,
+  wrongGovernorRedeemer1,
 ) where
 
 import Agora.Governor (
   Governor (..),
   GovernorDatum (..),
-  GovernorRedeemer (CreateProposal),
+  GovernorRedeemer (
+    CreateProposal,
+    MintGATs,
+    MutateGovernor
+  ),
  )
 import Agora.Proposal (
   ProposalDatum (..),
+  ProposalEffectGroup,
   ProposalId (ProposalId),
   ProposalStatus (..),
   ResultTag (ResultTag),
   emptyVotesFor,
  )
-import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..))
-import Agora.Scripts (AgoraScripts (..))
+import Agora.Proposal.Time (
+  MaxTimeRangeWidth (
+    MaxTimeRangeWidth
+  ),
+  ProposalStartingTime (..),
+ )
+import Agora.SafeMoney (GTTag)
 import Agora.Stake (
-  ProposalLock (..),
+  ProposalAction (Created, Voted),
+  ProposalLock (ProposalLock),
   StakeDatum (..),
   StakeRedeemer (PermitVote),
  )
 import Data.Coerce (coerce)
 import Data.Default (Default (def))
-import Data.Tagged (Tagged, untag)
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged)
 import Plutarch.Context (
   input,
   mint,
+  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
   txId,
   withDatum,
-  withOutRef,
+  withRedeemer,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  DatumHash,
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
   POSIXTime (POSIXTime),
   POSIXTimeRange,
-  PubKeyHash,
+  Redeemer (Redeemer),
+  ToData (toBuiltinData),
   TxOutRef (TxOutRef),
-  ValidatorHash,
   always,
  )
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (stakeTxRef)
 import Sample.Shared (
-  agoraScripts,
-  govAssetClass,
-  govValidatorHash,
   governor,
+  governorAssetClass,
+  governorScriptHash,
+  governorValidator,
   minAda,
+  proposalAssetClass,
+  proposalPolicy,
   proposalPolicySymbol,
+  proposalScriptHash,
   proposalStartingTimeFromTimeRange,
-  proposalValidatorHash,
   signer,
   signer2,
   stakeAssetClass,
-  stakeValidatorHash,
+  stakeScriptHash,
+  stakeSymbol,
+  stakeValidator,
  )
 import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue)
+import Test.Util (
+  CombinableBuilder,
+  closedBoundedInterval,
+  mkMinting,
+  mkSpending,
+  sortValue,
+  validatorHashes,
+ )
 
 -- | Parameters for creating a proposal.
 data Parameters = Parameters
@@ -100,11 +129,15 @@ data Parameters = Parameters
   -- ^ Is 'TxInfo.validTimeRange' closed?
   , proposalStatus :: ProposalStatus
   -- ^ The status of the newly created proposal.
+  , fakeSST :: Bool
+  -- ^ Whether to use SST that doesn't belong to the stake validator.
+  , governorRedeemer :: Redeemer
+  -- ^ The redeemer used to spend the governor.
   }
 
 --------------------------------------------------------------------------------
 
--- | See 'GovernorDatum.maximumProposalsPerStake'.
+-- | See 'GovernorDatum.maximumCreatedProposalsPerStake'.
 maxProposalPerStake :: Integer
 maxProposalPerStake = 3
 
@@ -113,29 +146,30 @@ thisProposalId :: ProposalId
 thisProposalId = ProposalId 25
 
 -- | The arbitrary staked amount. Doesn;t really matter in this case.
-stakedGTs :: Tagged _ Integer
+stakedGTs :: Tagged GTTag Integer
 stakedGTs = 5
 
 -- | The owner of the stake.
-stakeOwner :: PubKeyHash
-stakeOwner = signer
+stakeOwner :: Credential
+stakeOwner = PubKeyCredential signer
 
 {- | The invalid stake owner. If the 'alterOutputStakeOwner' is set to true,
       the output stake owner will be set to this.
 -}
-alteredStakeOwner :: PubKeyHash
-alteredStakeOwner = signer2
+alteredStakeOwner :: Credential
+alteredStakeOwner = PubKeyCredential signer2
 
 -- | Locks the stake that the input stake already has.
 defLocks :: [ProposalLock]
-defLocks = [Created (ProposalId 0)]
+defLocks = [ProposalLock (ProposalId 0) Created]
 
 -- | The effect of the newly created proposal.
-defEffects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+defEffects :: StrictMap.Map ResultTag ProposalEffectGroup
 defEffects =
-  AssocMap.fromList
-    [ (ResultTag 0, AssocMap.empty)
-    , (ResultTag 1, AssocMap.empty)
+  StrictMap.fromList
+    [ (ResultTag 0, StrictMap.empty)
+    , (ResultTag 1, StrictMap.empty)
+    , (ResultTag 3, StrictMap.empty)
     ]
 
 --------------------------------------------------------------------------------
@@ -148,7 +182,7 @@ governorInputDatum =
     , nextProposalId = thisProposalId
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumProposalsPerStake = maxProposalPerStake
+    , maximumCreatedProposalsPerStake = maxProposalPerStake
     }
 
 -- | Create governor output datum given the parameters.
@@ -163,7 +197,7 @@ mkGovernorOutputDatum ps =
         , nextProposalId = nextPid
         , proposalTimings = def
         , createProposalTimeRangeMaxWidth = def
-        , maximumProposalsPerStake = maxProposalPerStake
+        , maximumCreatedProposalsPerStake = maxProposalPerStake
         }
 
 --------------------------------------------------------------------------------
@@ -174,7 +208,7 @@ mkStakeInputDatum ps =
   let locks =
         if ps.createdMoreThanMaximumProposals
           then
-            Created . ProposalId
+            flip ProposalLock Created . ProposalId
               <$> take
                 (fromInteger maxProposalPerStake)
                 [1 ..]
@@ -193,10 +227,10 @@ mkStakeOutputDatum ps =
       newLocks =
         if ps.invalidNewLocks
           then
-            [ Voted thisProposalId (ResultTag 0)
-            , Voted thisProposalId (ResultTag 1)
+            [ ProposalLock thisProposalId $ Voted (ResultTag 0) 100
+            , ProposalLock thisProposalId $ Voted (ResultTag 1) 100
             ]
-          else [Created thisProposalId]
+          else [ProposalLock thisProposalId Created]
       locks = newLocks <> inputDatum.lockedBy
       newOwner = mkOwner ps
    in inputDatum
@@ -211,16 +245,18 @@ mkStakeOutputDatum ps =
 -}
 mkProposalOutputDatum :: Parameters -> ProposalDatum
 mkProposalOutputDatum ps =
-  ProposalDatum
-    { proposalId = thisProposalId
-    , effects = defEffects
-    , status = ps.proposalStatus
-    , cosigners = [mkOwner ps]
-    , thresholds = def
-    , votes = emptyVotesFor defEffects
-    , timingConfig = def
-    , startingTime = mkProposalStartingTime ps
-    }
+  let effects = defEffects
+      votes = emptyVotesFor defEffects
+   in ProposalDatum
+        { proposalId = thisProposalId
+        , effects = effects
+        , status = ps.proposalStatus
+        , cosigners = [mkOwner ps]
+        , thresholds = def
+        , votes = votes
+        , timingConfig = def
+        , startingTime = mkProposalStartingTime ps
+        }
 
 --------------------------------------------------------------------------------
 
@@ -243,7 +279,7 @@ mkProposalStartingTime ps =
     else ProposalStartingTime 0
 
 -- | Who should be the 'owner' of the output stake.
-mkOwner :: Parameters -> PubKeyHash
+mkOwner :: Parameters -> Credential
 mkOwner ps =
   if ps.alterOutputStakeOwner
     then alteredStakeOwner
@@ -265,26 +301,51 @@ governorRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be
 createProposal :: forall b. CombinableBuilder b => Parameters -> b
 createProposal ps = builder
   where
-    pst = Value.singleton proposalPolicySymbol "" 1
-    sst = Value.assetClassValue stakeAssetClass 1
-    gst = Value.assetClassValue govAssetClass 1
+    pst = assetClassValue proposalAssetClass 1
+    sst = assetClassValue stakeAssetClass 1
+    gst = assetClassValue governorAssetClass 1
+
+    ---
+
+    attacker = head validatorHashes
+
+    fakeStakeBuilder =
+      if ps.fakeSST
+        then
+          mconcat
+            [ input @b $
+                mconcat
+                  [ script attacker
+                  , withValue $
+                      Value.singleton
+                        stakeSymbol
+                        (scriptHashToTokenName attacker)
+                        1
+                  , withDatum $
+                      (mkStakeInputDatum ps)
+                        { stakedAmount = 10000000000
+                        }
+                  ]
+            ]
+        else mempty
 
     ---
 
     governorValue = sortValue $ gst <> minAda
     stakeValue =
       sortValue $
-        sortValue $
-          sst
-            <> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
-            <> minAda
+        sst
+          <> assetClassValue governor.gtClassRef stakedGTs
+          <> minAda
     proposalValue = sortValue $ pst <> minAda
 
     ---
 
     withSig =
       if ps.stakeOwnerSignsTheTransaction
-        then signedWith stakeOwner
+        then case stakeOwner of
+          PubKeyCredential sig -> signedWith sig
+          _ -> mempty
         else mempty
 
     ---
@@ -295,43 +356,68 @@ createProposal ps = builder
         , ---
           withSig
         , ---
-          mint pst
+          mint $
+            normalizeValue
+              pst
         , ---
           timeRange $ mkTimeRange ps
         , input $
             mconcat
-              [ script govValidatorHash
+              [ script governorScriptHash
               , withValue governorValue
               , withDatum governorInputDatum
-              , withOutRef governorRef
+              , withRedeemer ps.governorRedeemer
+              , withRef governorRef
               ]
         , output $
             mconcat
-              [ script govValidatorHash
+              [ script governorScriptHash
               , withValue governorValue
               , withDatum (mkGovernorOutputDatum ps)
               ]
         , ---
-          input $
-            mconcat
-              [ script stakeValidatorHash
-              , withValue stakeValue
-              , withDatum (mkStakeInputDatum ps)
-              , withOutRef stakeRef
-              ]
-        , output $
-            mconcat
-              [ script stakeValidatorHash
-              , withValue stakeValue
-              , withDatum (mkStakeOutputDatum ps)
-              ]
+          if ps.fakeSST
+            then
+              mconcat
+                [ input @b $
+                    mconcat
+                      [ script attacker
+                      , withValue $
+                          Value.singleton
+                            stakeSymbol
+                            (scriptHashToTokenName attacker)
+                            1
+                      , withDatum $
+                          (mkStakeInputDatum ps)
+                            { stakedAmount = 10000000000
+                            }
+                      ]
+                ]
+            else
+              mconcat
+                [ input $
+                    mconcat
+                      [ script stakeScriptHash
+                      , withValue stakeValue
+                      , withDatum (mkStakeInputDatum ps)
+                      , withRef stakeRef
+                      ]
+                , output $
+                    mconcat
+                      [ script stakeScriptHash
+                      , withValue stakeValue
+                      , withDatum (mkStakeOutputDatum ps)
+                      ]
+                ]
         , ---
           output $
             mconcat
-              [ script proposalValidatorHash
+              [ script proposalScriptHash
               , withValue proposalValue
               , withDatum (mkProposalOutputDatum ps)
               ]
+        , ---
+          fakeStakeBuilder
         ]
 
 --------------------------------------------------------------------------------
@@ -340,10 +426,6 @@ createProposal ps = builder
 stakeRedeemer :: StakeRedeemer
 stakeRedeemer = PermitVote
 
--- | Spend the governor with the 'CreateProposal' redeemer.
-governorRedeemer :: GovernorRedeemer
-governorRedeemer = CreateProposal
-
 -- | Mint the PST with an arbitrary redeemer. Doesn't really matter.
 proposalPolicyRedeemer :: ()
 proposalPolicyRedeemer = ()
@@ -361,6 +443,8 @@ totallyValidParameters =
     , timeRangeTightEnough = True
     , timeRangeClosed = True
     , proposalStatus = Draft
+    , fakeSST = False
+    , governorRedeemer = Redeemer $ toBuiltinData CreateProposal
     }
 
 invalidOutputGovernorDatumParameters :: Parameters
@@ -413,6 +497,24 @@ invalidProposalStatusParameters =
     )
     [VotingReady, Locked, Finished]
 
+fakeSSTParameters :: Parameters
+fakeSSTParameters =
+  totallyValidParameters
+    { fakeSST = True
+    }
+
+wrongGovernorRedeemer :: Parameters
+wrongGovernorRedeemer =
+  totallyValidParameters
+    { governorRedeemer = Redeemer $ toBuiltinData MintGATs
+    }
+
+wrongGovernorRedeemer1 :: Parameters
+wrongGovernorRedeemer1 =
+  totallyValidParameters
+    { governorRedeemer = Redeemer $ toBuiltinData MutateGovernor
+    }
+
 --------------------------------------------------------------------------------
 
 {- | Create a test tree that runs the proposal minting policy, the governor
@@ -435,7 +537,7 @@ mkTestTree
         testPolicy
           validForProposalPolicy
           "proposal"
-          agoraScripts.compiledProposalPolicy
+          proposalPolicy
           proposalPolicyRedeemer
           (mint proposalPolicySymbol)
 
@@ -443,16 +545,16 @@ mkTestTree
         testValidator
           validForGovernorValidator
           "governor"
-          agoraScripts.compiledGovernorValidator
+          governorValidator
           governorInputDatum
-          governorRedeemer
+          ps.governorRedeemer
           (spend governorRef)
 
       stakeTest =
         testValidator
           validForStakeValidator
           "stake"
-          agoraScripts.compiledStakeValidator
+          stakeValidator
           (mkStakeInputDatum ps)
           stakeRedeemer
           (spend stakeRef)

agora-specs/Sample/Proposal/PrivilegeEscalate.hs

@@ -0,0 +1,254 @@
+module Sample.Proposal.PrivilegeEscalate (
+  Operation (..),
+  privilegeEscalate,
+  Validity (..),
+  mkTestTree,
+) where
+
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalId (ProposalId),
+  ProposalRedeemer (UnlockStake, Vote),
+  ProposalStatus (VotingReady),
+  ProposalVotes (ProposalVotes),
+  ResultTag (ResultTag),
+  emptyVotesFor,
+ )
+import Agora.Proposal.Time (
+  ProposalStartingTime (ProposalStartingTime),
+  ProposalTimingConfig (draftTime, votingTime),
+ )
+import Agora.SafeMoney (GTTag)
+import Agora.Stake (
+  ProposalAction (
+    Voted
+  ),
+  ProposalLock (ProposalLock),
+  StakeDatum (..),
+  StakeRedeemer (PermitVote, RetractVotes),
+ )
+import Data.Default (Default (def))
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged, untag)
+import Plutarch.Context (
+  input,
+  normalizeValue,
+  output,
+  script,
+  signedWith,
+  timeRange,
+  withDatum,
+  withRedeemer,
+  withRef,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
+import PlutusLedgerApi.V2 (PubKeyHash, TxOutRef (TxOutRef))
+import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
+import Sample.Shared (
+  minAda,
+  proposalAssetClass,
+  proposalScriptHash,
+  proposalValidator,
+  stakeAssetClass,
+  stakeScriptHash,
+  stakeValidator,
+ )
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
+
+data Operation = Voting | RetractingVotes
+
+data Validity = Validity
+  { forStakeValidator :: Bool
+  , forProposalValidator :: Bool
+  }
+
+wrap :: forall x y. Operation -> (x -> x -> y) -> x -> x -> y
+wrap Voting = id
+wrap RetractingVotes = flip
+
+defStakeAmount :: Tagged GTTag Integer
+defStakeAmount = 100000
+
+defResultTag :: ResultTag
+defResultTag = ResultTag 0
+
+defProposalId :: ProposalId
+defProposalId = ProposalId 0
+
+mkProposalInputOutputDatum :: Operation -> (ProposalDatum, ProposalDatum)
+mkProposalInputOutputDatum op =
+  let effects = StrictMap.singleton defResultTag StrictMap.empty
+
+      proposal =
+        ProposalDatum
+          { proposalId = defProposalId
+          , effects = effects
+          , status = VotingReady
+          , cosigners = [] -- doesn't matter
+          , thresholds = def
+          , votes = emptyVotesFor effects
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 0
+          }
+
+      proposalWithVotes =
+        proposal
+          { votes =
+              ProposalVotes $
+                StrictMap.singleton defResultTag (untag defStakeAmount)
+          }
+   in wrap op (,) proposal proposalWithVotes
+
+mkProposalRedeemer :: Operation -> ProposalRedeemer
+mkProposalRedeemer op = wrap op const (Vote defResultTag) UnlockStake
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef proposalTxRef 1
+
+attacker :: PubKeyHash
+attacker = head pubKeyHashes
+
+mkStakeInputOutputDatums :: Operation -> ([StakeDatum], [StakeDatum])
+mkStakeInputOutputDatums op =
+  let delegatee = pubKeyHashes !! 1
+
+      firstStake =
+        StakeDatum
+          { stakedAmount = defStakeAmount
+          , owner = PubKeyCredential attacker
+          , delegatedTo = Just $ PubKeyCredential delegatee
+          , lockedBy = []
+          }
+
+      otherStakes =
+        (\pkh -> firstStake {owner = PubKeyCredential pkh})
+          <$> drop 2 pubKeyHashes
+
+      allStakes = take 10 $ firstStake : otherStakes
+
+      createdAt = (def :: ProposalTimingConfig).votingTime - 1
+
+      stakeWithLock =
+        ( \stake ->
+            stake
+              { lockedBy =
+                  [ ProposalLock defProposalId $
+                      Voted
+                        defResultTag
+                        createdAt
+                  ]
+              }
+        )
+          <$> allStakes
+   in wrap op (,) allStakes stakeWithLock
+
+mkStakeRedeemer :: Operation -> StakeRedeemer
+mkStakeRedeemer op = wrap op const PermitVote RetractVotes
+
+mkStakeRef :: Integer -> TxOutRef
+mkStakeRef o = TxOutRef stakeTxRef $ 1 + o
+
+privilegeEscalate :: forall b. CombinableBuilder b => Operation -> b
+privilegeEscalate op =
+  let sst = assetClassValue stakeAssetClass 1
+
+      stakeValue = normalizeValue $ minAda <> sst
+
+      (stakeInputDatums, stakeOutputDatums) = mkStakeInputOutputDatums op
+
+      stakeBuilder =
+        mconcat $
+          zipWith3
+            ( \index stakeInput stakeOutput ->
+                mconcat @b
+                  [ input $
+                      mconcat
+                        [ script stakeScriptHash
+                        , withDatum stakeInput
+                        , withValue stakeValue
+                        , withRef $ mkStakeRef index
+                        , withRedeemer $ mkStakeRedeemer op
+                        ]
+                  , output $
+                      mconcat
+                        [ script stakeScriptHash
+                        , withDatum stakeOutput
+                        , withValue stakeValue
+                        ]
+                  ]
+            )
+            [1 ..]
+            stakeInputDatums
+            stakeOutputDatums
+
+      ---
+
+      pst = assetClassValue proposalAssetClass 1
+
+      proposalValue = normalizeValue $ minAda <> pst
+
+      (proposalInput, proposalOutput) = mkProposalInputOutputDatum op
+
+      proposalBuilder =
+        mconcat @b
+          [ input $
+              mconcat
+                [ script proposalScriptHash
+                , withDatum proposalInput
+                , withRedeemer $ mkProposalRedeemer op
+                , withValue proposalValue
+                , withRef proposalRef
+                ]
+          , output $
+              mconcat
+                [ script proposalScriptHash
+                , withDatum proposalOutput
+                , withValue proposalValue
+                ]
+          ]
+
+      ---
+
+      validTimeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).draftTime + 1)
+          ((def :: ProposalTimingConfig).votingTime - 1)
+
+      miscBuilder =
+        mconcat @b
+          [ signedWith attacker
+          , timeRange validTimeRange
+          ]
+   in mconcat
+        [ miscBuilder
+        , stakeBuilder
+        , proposalBuilder
+        ]
+
+mkTestTree :: String -> Operation -> Validity -> SpecificationTree
+mkTestTree name op val = group name [proposal, stake]
+  where
+    spend = mkSpending privilegeEscalate op
+
+    proposal =
+      testValidator
+        val.forProposalValidator
+        "proposal"
+        proposalValidator
+        (fst $ mkProposalInputOutputDatum op)
+        (mkProposalRedeemer op)
+        (spend proposalRef)
+
+    stakeInputdDatum = head $ fst $ mkStakeInputOutputDatums op
+
+    stake =
+      testValidator
+        val.forStakeValidator
+        "stake"
+        stakeValidator
+        stakeInputdDatum
+        (mkStakeRedeemer op)
+        (spend $ mkStakeRef 1)

agora-specs/Sample/Proposal/Shared.hs

@@ -7,7 +7,7 @@ Shared constants for proposal samples.
 -}
 module Sample.Proposal.Shared (proposalTxRef, stakeTxRef, governorTxRef) where
 
-import PlutusLedgerApi.V1 (TxId)
+import PlutusLedgerApi.V2 (TxId)
 
 -- | 'TxId' of all the proposal inputs in the samples.
 proposalTxRef :: TxId

agora-specs/Sample/Proposal/Unlock.hs

@@ -0,0 +1,612 @@
+{- |
+Module     : Sample.Proposal.UnlockStake
+Maintainer : connor@mlabs.city
+Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
+
+Sample and utilities for testing the functionalities of unlocking stake and retracting votes
+-}
+module Sample.Proposal.Unlock (
+  ParameterBundle (..),
+  StakeRole (..),
+  TimeRange (..),
+  SignedBy (..),
+  TransactionParameters (..),
+  ProposalParameters (..),
+  SSTOwner (..),
+  StakeParameters (..),
+  Validity (..),
+  unlock,
+  mkTestTree,
+  mkValidVoterRetractVotes,
+  mkValidDelegateeRetractVotes,
+  mkValidVoterCreatorRetractVotes,
+  mkValidCreatorRemoveLock,
+  mkValidVoterRemoveLockAfterVoting,
+  mkRetractVotesWhileNotVoting,
+  mkUnockIrrelevantStakes,
+  mkRemoveCreatorLockBeforeFinished,
+  mkCreatorRetractVotes,
+  mkChangeOutputStakeValue,
+  mkUseFakeStakes,
+  mkDisrespectCooldown,
+) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Governor (Governor (..))
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalEffectGroup,
+  ProposalId (..),
+  ProposalRedeemer (UnlockStake),
+  ProposalStatus (..),
+  ProposalVotes (..),
+  ResultTag (..),
+ )
+import Agora.Proposal.Time (
+  ProposalStartingTime (ProposalStartingTime),
+  ProposalTimingConfig (..),
+ )
+import Agora.SafeMoney (GTTag)
+import Agora.Stake (
+  ProposalAction (Created, Voted),
+  ProposalLock (..),
+  StakeDatum (..),
+  StakeRedeemer (RetractVotes),
+ )
+import Data.Coerce (coerce)
+import Data.Default.Class (Default (def))
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged, untag)
+import Plutarch.Context (
+  input,
+  normalizeValue,
+  output,
+  script,
+  signedWith,
+  timeRange,
+  txId,
+  withDatum,
+  withRedeemer,
+  withRef,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
+  POSIXTime,
+  PubKeyHash,
+  TxOutRef (..),
+ )
+import Sample.Proposal.Shared (stakeTxRef)
+import Sample.Shared (
+  governor,
+  minAda,
+  proposalAssetClass,
+  proposalScriptHash,
+  proposalValidator,
+  stakeScriptHash,
+  stakeSymbol,
+  stakeValidator,
+ )
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
+
+--------------------------------------------------------------------------------
+
+votesTemplate :: ProposalVotes
+votesTemplate =
+  ProposalVotes $
+    StrictMap.fromList
+      [ (ResultTag 0, 0)
+      , (ResultTag 1, 0)
+      ]
+
+-- | Create empty effects for every result tag given the votes.
+emptyEffectFor ::
+  ProposalVotes ->
+  StrictMap.Map ResultTag ProposalEffectGroup
+emptyEffectFor (ProposalVotes vs) =
+  StrictMap.fromList $
+    map (,StrictMap.empty) (StrictMap.keys vs)
+
+-- | The default vote option that will be used by functions in this module.
+defVoteFor :: ResultTag
+defVoteFor = ResultTag 0
+
+-- | The default number of GTs the stake will have.
+defStakedGTs :: Tagged GTTag Integer
+defStakedGTs = 100000
+
+alteredStakedGTs :: Tagged GTTag Integer
+alteredStakedGTs = 100
+
+-- | Default owner of the stakes.
+defOwner :: PubKeyHash
+defOwner = pubKeyHashes !! 1
+
+defDelegatee :: PubKeyHash
+defDelegatee = pubKeyHashes !! 2
+
+defUnknown :: PubKeyHash
+defUnknown = pubKeyHashes !! 3
+
+defProposalId :: ProposalId
+defProposalId = ProposalId 0
+
+defStartingTime :: ProposalStartingTime
+defStartingTime = ProposalStartingTime 0
+
+--------------------------------------------------------------------------------
+
+data ParameterBundle = ParameterBundle
+  { proposalParameters :: ProposalParameters
+  , stakeParameters :: StakeParameters
+  , transactionParameters :: TransactionParameters
+  }
+
+data SignedBy = Owner | Delegatee | Unknown
+
+data TimeRange = WhileVoting {offset :: POSIXTime} | AfterVoting
+
+data TransactionParameters = TransactionParameters
+  { signedBy :: SignedBy
+  , timeRange :: TimeRange
+  }
+
+data ProposalParameters = ProposalParameters
+  { proposalStatus :: ProposalStatus
+  , retractVotes :: Bool
+  }
+
+-- | How a stake has been used on a particular proposal.
+data StakeRole
+  = -- | The stake was spent to vote for a paraticular option.
+    Voter
+  | -- | The stake was used to create the proposal.
+    Creator
+  | -- | The stake was used to both create and vote for the proposal.
+    Both
+  | -- | The stake has nothing to do with the proposal.
+    Irrelevant
+  deriving stock (Bounded, Enum, Show)
+
+data SSTOwner
+  = StakeValidator
+  | Attacker
+
+data StakeParameters = StakeParameters
+  { numStakes :: Integer
+  , stakeRole :: StakeRole
+  , removeVoterLock :: Bool
+  , removeCreatorLock :: Bool
+  , alterOutputValue :: Bool
+  , sstOwner :: SSTOwner
+  , votingLockCreatedAt :: POSIXTime
+  }
+
+data Validity = Validity
+  { forProposalValidator :: Bool
+  , forStakeValidator :: Bool
+  }
+
+--------------------------------------------------------------------------------
+
+mkStakeRef :: Integer -> TxOutRef
+mkStakeRef = TxOutRef stakeTxRef
+
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = RetractVotes
+
+mkStakeInputDatum :: StakeParameters -> StakeDatum
+mkStakeInputDatum ps =
+  StakeDatum
+    { stakedAmount = defStakedGTs
+    , owner = PubKeyCredential defOwner
+    , delegatedTo = Just $ PubKeyCredential defDelegatee
+    , lockedBy = stakeLocks
+    }
+  where
+    stakeLocks = mkStakeLocks' ps.stakeRole
+
+    mkStakeLocks' Voter =
+      [ ProposalLock defProposalId $
+          Voted defVoteFor ps.votingLockCreatedAt
+      ]
+    mkStakeLocks' Creator = [ProposalLock defProposalId Created]
+    mkStakeLocks' Both = mkStakeLocks' Voter <> mkStakeLocks' Creator
+    mkStakeLocks' Irrelevant =
+      let ProposalId pid = defProposalId
+          ResultTag vid = defVoteFor
+       in [ ProposalLock (ProposalId $ pid + 1) $
+              Voted
+                (ResultTag $ vid + 1)
+                ps.votingLockCreatedAt
+          , ProposalLock (ProposalId $ pid + 1) Created
+          ]
+
+--------------------------------------------------------------------------------
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef stakeTxRef 0
+
+proposalRedeemer :: ProposalRedeemer
+proposalRedeemer = UnlockStake
+
+mkProposalInputDatum ::
+  StakeParameters ->
+  ProposalParameters ->
+  ProposalDatum
+mkProposalInputDatum sps pps =
+  ProposalDatum
+    { proposalId = defProposalId
+    , effects = emptyEffectFor votesTemplate
+    , status = pps.proposalStatus
+    , cosigners = [PubKeyCredential $ head pubKeyHashes]
+    , thresholds = def
+    , votes = updatVotes votesTemplate
+    , timingConfig = def
+    , startingTime = defStartingTime
+    }
+  where
+    updatVotes (ProposalVotes vt) =
+      ProposalVotes $
+        StrictMap.adjust
+          (+ sps.numStakes * untag defStakedGTs)
+          defVoteFor
+          vt
+
+--------------------------------------------------------------------------------
+
+unlock :: forall b. CombinableBuilder b => ParameterBundle -> b
+unlock ps = builder
+  where
+    pst = assetClassValue proposalAssetClass 1
+
+    proposalInputDatum =
+      mkProposalInputDatum
+        ps.stakeParameters
+        ps.proposalParameters
+
+    proposalOutputDatum =
+      if ps.proposalParameters.retractVotes
+        then proposalInputDatum {votes = votesTemplate}
+        else proposalInputDatum
+
+    proposalValue = normalizeValue $ pst <> minAda
+
+    proposalBuilder :: b
+    proposalBuilder =
+      mconcat
+        [ input $
+            mconcat
+              [ script proposalScriptHash
+              , withValue proposalValue
+              , withDatum proposalInputDatum
+              , withRef proposalRef
+              , withRedeemer proposalRedeemer
+              ]
+        , output $
+            mconcat
+              [ script proposalScriptHash
+              , withValue proposalValue
+              , withDatum proposalOutputDatum
+              ]
+        ]
+
+    ---
+
+    sstName = case ps.stakeParameters.sstOwner of
+      StakeValidator -> scriptHashToTokenName stakeScriptHash
+      _ -> ""
+
+    sst = Value.singleton stakeSymbol sstName 1
+
+    stakeInputDatum = mkStakeInputDatum ps.stakeParameters
+
+    -- TODO respect timing
+    removeLocks v c =
+      filter $ \(ProposalLock pid action) ->
+        pid == defProposalId
+          && not
+            ( case action of
+                Voted _ _ -> v
+                _ -> c
+            )
+
+    stakeOutputDatum =
+      stakeInputDatum
+        { lockedBy =
+            removeLocks
+              ps.stakeParameters.removeVoterLock
+              ps.stakeParameters.removeCreatorLock
+              stakeInputDatum.lockedBy
+        }
+
+    mkStakeValue gt =
+      normalizeValue $
+        mconcat
+          [ minAda
+          , sst
+          , assetClassValue
+              governor.gtClassRef
+              gt
+          ]
+
+    stakeInputValue = mkStakeValue defStakedGTs
+
+    stakeOutputValue =
+      mkStakeValue $
+        if ps.stakeParameters.alterOutputValue
+          then alteredStakedGTs
+          else defStakedGTs
+
+    stakeBuilder :: b
+    stakeBuilder =
+      foldMap
+        ( \i ->
+            mconcat
+              [ input $
+                  mconcat
+                    [ script stakeScriptHash
+                    , withValue stakeInputValue
+                    , withDatum stakeInputDatum
+                    , withRef $ mkStakeRef i
+                    ]
+              , output $
+                  mconcat
+                    [ script stakeScriptHash
+                    , withValue stakeOutputValue
+                    , withDatum stakeOutputDatum
+                    ]
+              ]
+        )
+        [1 .. ps.stakeParameters.numStakes]
+
+    ---
+
+    ProposalStartingTime s = defStartingTime
+
+    time = case ps.transactionParameters.timeRange of
+      WhileVoting offset ->
+        let lb =
+              ps.stakeParameters.votingLockCreatedAt
+                + offset
+            ub =
+              s
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+         in closedBoundedInterval (lb + 1) (ub - 1)
+      AfterVoting ->
+        let lb =
+              s
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+            ub = lb + (def :: ProposalTimingConfig).lockingTime
+         in closedBoundedInterval (lb + 1) (ub - 1)
+
+    sig = case ps.transactionParameters.signedBy of
+      Unknown -> defUnknown
+      Owner -> defOwner
+      Delegatee -> defDelegatee
+
+    ---
+
+    builder =
+      mconcat
+        [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
+        , proposalBuilder
+        , stakeBuilder
+        , signedWith sig
+        , timeRange time
+        ]
+
+--------------------------------------------------------------------------------
+
+{- | Create a test tree that runs both the stake validator and the proposal
+     validator.
+-}
+mkTestTree :: String -> ParameterBundle -> Validity -> SpecificationTree
+mkTestTree name ps val = group name [stake, proposal]
+  where
+    spend = mkSpending unlock ps
+
+    stake =
+      testValidator
+        val.forStakeValidator
+        "stake"
+        stakeValidator
+        (mkStakeInputDatum ps.stakeParameters)
+        stakeRedeemer
+        (spend $ mkStakeRef 1)
+
+    proposal =
+      testValidator
+        val.forProposalValidator
+        "proposal"
+        proposalValidator
+        (mkProposalInputDatum ps.stakeParameters ps.proposalParameters)
+        proposalRedeemer
+        (spend proposalRef)
+
+--------------------------------------------------------------------------------
+
+mkValidVoterRetractVotes :: Integer -> ParameterBundle
+mkValidVoterRetractVotes i =
+  ParameterBundle
+    { proposalParameters =
+        ProposalParameters
+          { proposalStatus = VotingReady
+          , retractVotes = True
+          }
+    , stakeParameters =
+        StakeParameters
+          { numStakes = i
+          , stakeRole = Voter
+          , removeVoterLock = True
+          , removeCreatorLock = False
+          , alterOutputValue = False
+          , sstOwner = StakeValidator
+          , votingLockCreatedAt =
+              coerce defStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + 1
+          }
+    , transactionParameters =
+        TransactionParameters
+          { signedBy = Owner
+          , timeRange =
+              WhileVoting
+                { offset =
+                    coerce
+                      (def :: ProposalTimingConfig).minStakeVotingTime
+                      + 5
+                }
+          }
+    }
+
+mkValidDelegateeRetractVotes :: Integer -> ParameterBundle
+mkValidDelegateeRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { transactionParameters =
+            template.transactionParameters
+              { signedBy = Delegatee
+              }
+        }
+
+mkValidVoterCreatorRetractVotes :: Integer -> ParameterBundle
+mkValidVoterCreatorRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { stakeRole = Both
+              }
+        }
+
+mkValidCreatorRemoveLock :: Integer -> ParameterBundle
+mkValidCreatorRemoveLock i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = Finished
+              , retractVotes = False
+              }
+        , stakeParameters =
+            template.stakeParameters
+              { stakeRole = Creator
+              , removeCreatorLock = True
+              }
+        , transactionParameters =
+            template.transactionParameters
+              { timeRange = AfterVoting
+              }
+        }
+
+mkValidVoterRemoveLockAfterVoting :: Integer -> ParameterBundle
+mkValidVoterRemoveLockAfterVoting i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = Finished
+              , retractVotes = False
+              }
+        , transactionParameters =
+            template.transactionParameters
+              { timeRange = AfterVoting
+              }
+        }
+
+mkRetractVotesWhileNotVoting :: Integer -> [ParameterBundle]
+mkRetractVotesWhileNotVoting i =
+  let template = mkValidVoterRetractVotes i
+   in map
+        ( \s ->
+            template
+              { proposalParameters =
+                  template.proposalParameters
+                    { proposalStatus = s
+                    }
+              }
+        )
+        [Draft, Locked, Finished]
+
+mkUnockIrrelevantStakes :: Integer -> ParameterBundle
+mkUnockIrrelevantStakes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { stakeRole = Irrelevant
+              , removeCreatorLock = True
+              }
+        }
+
+mkRemoveCreatorLockBeforeFinished :: Integer -> [ParameterBundle]
+mkRemoveCreatorLockBeforeFinished i =
+  let template = mkValidCreatorRemoveLock i
+   in map
+        ( \s ->
+            template
+              { proposalParameters =
+                  template.proposalParameters
+                    { proposalStatus = s
+                    }
+              }
+        )
+        [Draft, VotingReady, Locked]
+
+mkCreatorRetractVotes :: Integer -> ParameterBundle
+mkCreatorRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = VotingReady
+              }
+        , stakeParameters =
+            template.stakeParameters
+              { stakeRole = Creator
+              }
+        }
+
+mkChangeOutputStakeValue :: Integer -> ParameterBundle
+mkChangeOutputStakeValue i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { alterOutputValue = True
+              }
+        }
+
+mkUseFakeStakes :: Integer -> ParameterBundle
+mkUseFakeStakes i =
+  let template = mkValidVoterCreatorRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { sstOwner = Attacker
+              }
+        }
+
+mkDisrespectCooldown :: Integer -> ParameterBundle
+mkDisrespectCooldown i =
+  let template = mkValidVoterCreatorRetractVotes i
+   in template
+        { transactionParameters =
+            template.transactionParameters
+              { timeRange =
+                  WhileVoting
+                    { offset =
+                        coerce
+                          (def :: ProposalTimingConfig).minStakeVotingTime
+                          - 5
+                    }
+              }
+        }

agora-specs/Sample/Proposal/UnlockStake.hs

@@ -1,550 +0,0 @@
-{- |
-Module     : Sample.Proposal.UnlockStake
-Maintainer : connor@mlabs.city
-Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
-
-Sample and utilities for testing the functionalities of unlocking stake and retracting votes
--}
-module Sample.Proposal.UnlockStake (
-  StakeRole (..),
-  Parameters (..),
-  unlockStake,
-  mkTestTree,
-  mkVoterRetractVotesWhileVotingParameters,
-  mkVoterCreatorRetractVotesWhileVotingParameters,
-  mkCreatorRemoveCreatorLocksWhenFinishedParameters,
-  mkVoterCreatorRemoveAllLocksWhenFinishedParameters,
-  mkVoterUnlockStakeAfterVotingParameters,
-  mkVoterCreatorRemoveVoteLocksWhenLockedParameters,
-  mkRetractVotesWhileNotVoting,
-  mkUnockIrrelevantStakeParameters,
-  mkRemoveCreatorLockBeforeFinishedParameters,
-  mkRetractVotesWithCreatorStakeParamaters,
-  mkAlterStakeParameters,
-) where
-
---------------------------------------------------------------------------------
-
-import Agora.Governor (Governor (..))
-import Agora.Proposal (
-  ProposalDatum (..),
-  ProposalId (..),
-  ProposalRedeemer (Unlock),
-  ProposalStatus (..),
-  ProposalVotes (..),
-  ResultTag (..),
- )
-import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
-import Agora.Scripts (AgoraScripts (..))
-import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
-import Data.Default.Class (Default (def))
-import Data.Tagged (Tagged (..), untag)
-import Plutarch.Context (
-  input,
-  output,
-  script,
-  signedWith,
-  txId,
-  withDatum,
-  withOutRef,
-  withValue,
- )
-import PlutusLedgerApi.V1 (
-  DatumHash,
-  PubKeyHash,
-  TxOutRef (..),
-  ValidatorHash,
- )
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusTx.AssocMap qualified as AssocMap
-import Sample.Proposal.Shared (stakeTxRef)
-import Sample.Shared (
-  agoraScripts,
-  governor,
-  minAda,
-  proposalPolicySymbol,
-  proposalValidatorHash,
-  signer,
-  stakeAssetClass,
-  stakeValidatorHash,
- )
-import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
-
---------------------------------------------------------------------------------
-
--- | The template "shape" that votes of proposals generated by 'mkProposalDatumPair' have.
-votesTemplate :: ProposalVotes
-votesTemplate =
-  ProposalVotes $
-    AssocMap.fromList
-      [ (ResultTag 0, 0)
-      , (ResultTag 1, 0)
-      ]
-
--- | Create empty effects for every result tag given the votes.
-emptyEffectFor ::
-  ProposalVotes ->
-  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
-emptyEffectFor (ProposalVotes vs) =
-  AssocMap.fromList $
-    map (,AssocMap.empty) (AssocMap.keys vs)
-
--- | The default vote option that will be used by functions in this module.
-defVoteFor :: ResultTag
-defVoteFor = ResultTag 0
-
--- | The default number of GTs the stake will have.
-defStakedGTs :: Tagged _ Integer
-defStakedGTs = 100000
-
-{- | If 'Parameters.alterOutputStake' is set to true, the
-     'StakeDatum.stakedAmount' will be set to this.
--}
-alteredStakedGTs :: Tagged _ Integer
-alteredStakedGTs = 100
-
--- | Default owner of the stakes.
-defOwner :: PubKeyHash
-defOwner = signer
-
--- | How a stake has been used on a particular proposal.
-data StakeRole
-  = -- | The stake was spent to vote for a paraticular option.
-    Voter
-  | -- | The stake was used to create the proposal.
-    Creator
-  | -- | The stake was used to both create and vote for the proposal.
-    Both
-  | -- | The stake has nothing to do with the proposal.
-    Irrelevant
-  deriving stock (Bounded, Enum, Show)
-
--- | Parameters for creating a 'TxOut' that unlocks a stake.
-data Parameters = Parameters
-  { proposalCount :: Integer
-  -- ^ The number of proposals in the 'TxOut'.
-  , stakeRole :: StakeRole
-  -- ^ The role of the stake we're unlocking.
-  , retractVotes :: Bool
-  -- ^ Whether to retract votes or not.
-  , removeVoterLock :: Bool
-  -- ^ Remove the voter locks from the input stake.
-  , removeCreatorLock :: Bool
-  -- ^ Remove the creator locks from the input stake.
-  , proposalStatus :: ProposalStatus
-  -- ^ The state of all the proposals.
-  , alterOutputStake :: Bool
-  }
-
--- | Iterate over the proposal id of every proposal, given the number of proposals.
-forEachProposalId :: Parameters -> (ProposalId -> a) -> [a]
-forEachProposalId ps = forEachProposalId' ps.proposalCount
-  where
-    forEachProposalId' :: Integer -> (ProposalId -> a) -> [a]
-    forEachProposalId' 0 _ = error "zero proposal"
-    forEachProposalId' n f = f . ProposalId <$> [0 .. n - 1]
-
--- | Create locks for the input stake given the parameters.
-mkInputStakeLocks :: Parameters -> [ProposalLock]
-mkInputStakeLocks ps = mconcat $ forEachProposalId ps $ mkStakeLocksFor ps.stakeRole
-  where
-    mkStakeLocksFor :: StakeRole -> ProposalId -> [ProposalLock]
-    mkStakeLocksFor sr pid =
-      let voted = [Voted pid defVoteFor]
-          created = [Created pid]
-       in case sr of
-            Voter -> voted
-            Creator -> created
-            Both -> voted <> created
-            _ -> []
-
--- | Create locks for the output stake by removing locks from the input locks.
-mkOutputStakeLocks :: Parameters -> [ProposalLock]
-mkOutputStakeLocks ps =
-  filter
-    ( \lock -> not $ case lock of
-        Voted _ _ -> ps.removeVoterLock
-        Created _ -> ps.removeCreatorLock
-    )
-    inputLocks
-  where
-    inputLocks = mkInputStakeLocks ps
-
--- | Create the stake input datum given the parameters.
-mkStakeInputDatum :: Parameters -> StakeDatum
-mkStakeInputDatum ps =
-  StakeDatum
-    { stakedAmount = defStakedGTs
-    , owner = defOwner
-    , delegatedTo = Nothing
-    , lockedBy = mkInputStakeLocks ps
-    }
-
--- | Create stake output datum given the parameters.
-mkStakeOutputDatum :: Parameters -> StakeDatum
-mkStakeOutputDatum ps =
-  let template = mkStakeInputDatum ps
-      stakedAmount' =
-        if ps.alterOutputStake
-          then alteredStakedGTs
-          else defStakedGTs
-   in template
-        { stakedAmount = stakedAmount'
-        , lockedBy = mkOutputStakeLocks ps
-        }
-
--- | Generate some input proposals and their corresponding output proposals.
-mkProposals :: Parameters -> [(ProposalDatum, ProposalDatum)]
-mkProposals ps = forEachProposalId ps $ mkProposalDatumPair ps
-
--- | Create the input proposal datum.
-mkProposalInputDatum :: Parameters -> ProposalId -> ProposalDatum
-mkProposalInputDatum p pid = fst $ mkProposalDatumPair p pid
-
--- | Create a input proposal and its corresponding output proposal.
-mkProposalDatumPair ::
-  Parameters ->
-  ProposalId ->
-  (ProposalDatum, ProposalDatum)
-mkProposalDatumPair params pid =
-  let inputVotes = mkInputVotes params.stakeRole $ untag defStakedGTs
-
-      input =
-        ProposalDatum
-          { proposalId = pid
-          , effects = emptyEffectFor votesTemplate
-          , status = params.proposalStatus
-          , cosigners = [defOwner]
-          , thresholds = def
-          , votes = inputVotes
-          , timingConfig = def
-          , startingTime = ProposalStartingTime 0
-          }
-
-      output =
-        if params.retractVotes
-          then input {votes = votesTemplate}
-          else input
-   in (input, output)
-  where
-    -- Assemble the votes of the input proposal based on 'votesTemplate'.
-    mkInputVotes ::
-      StakeRole ->
-      -- The staked amount/votes.
-      Integer ->
-      ProposalVotes
-    mkInputVotes Creator _ =
-      ProposalVotes $
-        updateMap (Just . const 1000) defVoteFor $
-          getProposalVotes votesTemplate
-    mkInputVotes Irrelevant _ = votesTemplate
-    mkInputVotes _ vc =
-      ProposalVotes $
-        updateMap (Just . const vc) defVoteFor $
-          getProposalVotes votesTemplate
-
--- | Create a 'TxInfo' that tries to unlock a stake.
-unlockStake :: forall b. CombinableBuilder b => Parameters -> b
-unlockStake ps =
-  let pst = Value.singleton proposalPolicySymbol "" 1
-      sst = Value.assetClassValue stakeAssetClass 1
-
-      pIODatums = mkProposals ps
-
-      proposals =
-        foldMap
-          ( \((i, o), idx) ->
-              mconcat
-                [ input $
-                    mconcat
-                      [ script proposalValidatorHash
-                      , withValue pst
-                      , withDatum i
-                      , withOutRef (mkProposalRef idx)
-                      ]
-                , output $
-                    mconcat
-                      [ script proposalValidatorHash
-                      , withValue (sortValue $ pst <> minAda)
-                      , withDatum o
-                      ]
-                ]
-          )
-          (zip pIODatums [0 ..])
-
-      stakeValue =
-        sortValue $
-          mconcat
-            [ Value.assetClassValue
-                (untag governor.gtClassRef)
-                (untag defStakedGTs)
-            , sst
-            , minAda
-            ]
-
-      sInDatum = mkStakeInputDatum ps
-      sOutDatum = mkStakeOutputDatum ps
-
-      stakes =
-        mconcat
-          [ input $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum sInDatum
-                , withOutRef stakeRef
-                ]
-          , output $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum sOutDatum
-                ]
-          ]
-
-      builder =
-        mconcat
-          [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
-          , proposals
-          , stakes
-          , signedWith defOwner
-          ]
-   in builder
-
--- | Reference to the stake UTXO.
-stakeRef :: TxOutRef
-stakeRef = TxOutRef stakeTxRef 1
-
--- | Generate the reference to a proposal UTXOs, given the index of the proposal.
-mkProposalRef :: Int -> TxOutRef
-mkProposalRef offset = TxOutRef stakeTxRef $ 2 + fromIntegral offset
-
--- | Proposal redeemer used by 'mkTestTree', in this case it's always 'Unlock'.
-proposalRedeemer :: ProposalRedeemer
-proposalRedeemer = Unlock
-
--- | Stake redeemer used by 'mkTestTree', in this case it's always 'RetractVotes'.
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = RetractVotes
-
---------------------------------------------------------------------------------
-
-{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
-      state, and also remove voter locks from the stake, which is
-      used to vote on the proposals.
--}
-mkVoterRetractVotesWhileVotingParameters :: Integer -> Parameters
-mkVoterRetractVotesWhileVotingParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Voter
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
-      state, and also remove voter locks from the stake, which is
-      used to both create and vote on the proposals.
--}
-mkVoterCreatorRetractVotesWhileVotingParameters :: Integer -> Parameters
-mkVoterCreatorRetractVotesWhileVotingParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that remove creator locks from the stake while the
-      proposals is in 'Finished' state. The stake was only used for creating
-      the proposals.
--}
-mkCreatorRemoveCreatorLocksWhenFinishedParameters :: Integer -> Parameters
-mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Creator
-    , retractVotes = False
-    , removeVoterLock = False
-    , removeCreatorLock = True
-    , proposalStatus = Finished
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that remove voter and creator locks from the stake while
-      the proposals is in 'Finished' state. The stake was used for creating
-      and voting on the proposals.
--}
-mkVoterCreatorRemoveAllLocksWhenFinishedParameters :: Integer -> Parameters
-mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = False
-    , removeVoterLock = True
-    , removeCreatorLock = True
-    , proposalStatus = Finished
-    , alterOutputStake = False
-    }
-
-{- Legal parameters that remove voter locks from the stake after the voting
-    phrase. The stake was used only for voting on the proposals.
--}
-mkVoterUnlockStakeAfterVotingParameters :: Integer -> [Parameters]
-mkVoterUnlockStakeAfterVotingParameters nProposals =
-  map
-    ( \st ->
-        Parameters
-          { proposalCount = nProposals
-          , stakeRole = Voter
-          , retractVotes = False
-          , removeVoterLock = True
-          , removeCreatorLock = False
-          , proposalStatus = st
-          , alterOutputStake = False
-          }
-    )
-    [Locked, Finished]
-
-{- Legal parameters that remove voter locks whenproposals are in phrase.
-    The stake was used for crating and voting on the proposals.
--}
-mkVoterCreatorRemoveVoteLocksWhenLockedParameters :: Integer -> Parameters
-mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = False
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = Locked
-    , alterOutputStake = False
-    }
-
-{- | Illegal parameters that retract votes when the proposals are not in voting
-      phrase.
--}
-mkRetractVotesWhileNotVoting :: Integer -> [Parameters]
-mkRetractVotesWhileNotVoting nProposals = do
-  role <- enumFrom Voter
-  status <- [Draft, Locked, Finished]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = role
-      , retractVotes = True
-      , removeVoterLock = True
-      , removeCreatorLock = False
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameter that try to unlock a stake that has nothing to do with
-      the proposals.
--}
-mkUnockIrrelevantStakeParameters :: Integer -> [Parameters]
-mkUnockIrrelevantStakeParameters nProposals = do
-  status <- [Draft, VotingReady, Locked, Finished]
-  retractVotes <- [True, False]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = Irrelevant
-      , retractVotes = retractVotes
-      , removeVoterLock = True
-      , removeCreatorLock = True
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameters that remove the creator locks before the proposals are
-      'Finished'.
--}
-mkRemoveCreatorLockBeforeFinishedParameters :: Integer -> [Parameters]
-mkRemoveCreatorLockBeforeFinishedParameters nProposals = do
-  status <- [Draft, VotingReady, Locked]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = Creator
-      , retractVotes = False
-      , removeVoterLock = False
-      , removeCreatorLock = True
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameters that try to retract votes with a stake that was only used
-    for creating the proposals.
--}
-mkRetractVotesWithCreatorStakeParamaters :: Integer -> Parameters
-mkRetractVotesWithCreatorStakeParamaters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Creator
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = True
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Illegal parameters that try to change the 'StakeDatum.stakedAmount' field of
-      the output stake datum.
--}
-mkAlterStakeParameters :: Integer -> [Parameters]
-mkAlterStakeParameters nProposals = do
-  role <- enumFrom Voter
-  status <- [Draft, Locked, Finished]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = role
-      , retractVotes = True
-      , removeVoterLock = True
-      , removeCreatorLock = False
-      , proposalStatus = status
-      , alterOutputStake = True
-      }
-
---------------------------------------------------------------------------------
-
-{- | Create a test tree that runs both the stake validator and the proposal
-     validator.
--}
-mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
-mkTestTree name ps isValid = group name [stake, proposal]
-  where
-    spend = mkSpending unlockStake ps
-
-    stake =
-      testValidator
-        (not ps.alterOutputStake)
-        "stake"
-        agoraScripts.compiledStakeValidator
-        (mkStakeInputDatum ps)
-        stakeRedeemer
-        (spend stakeRef)
-
-    proposal =
-      let idx = 0
-          pid = ProposalId $ fromIntegral idx
-          ref = mkProposalRef idx
-       in testValidator
-            isValid
-            "proposal"
-            agoraScripts.compiledProposalValidator
-            (mkProposalInputDatum ps pid)
-            proposalRedeemer
-            (spend ref)

agora-specs/Sample/Proposal/Vote.hs

@@ -2,13 +2,32 @@
 Module     : Sample.Proposal.Vote
 Maintainer : connor@mlabs.city
 Description: Generate sample data for testing the functionalities of voting on proposals.
-
 Sample and utilities for testing the functionalities of voting on proposals.
 -}
 module Sample.Proposal.Vote (
-  validVoteParameters,
+  ParameterBundle (..),
+  VoteParameters (..),
+  StakeParameters (..),
+  StakeInputParameters (..),
+  StakeOutputParameters (..),
+  NumProposals (..),
+  ProposalParameters (..),
+  TransactionParameters (..),
+  Validity (..),
+  vote,
   mkTestTree,
-  validVoteAsDelegateParameters,
+  mkValidOwnerVoteBundle,
+  mkValidDelegateeVoteBundle,
+  delegateeVoteWithOwnAndDelegatedStakeBundle,
+  transparentAssets,
+  transactionNotAuthorized,
+  voteForNonexistentOutcome,
+  noProposal,
+  moreThanOneProposals,
+  invalidLocks,
+  destroyStakes,
+  insufficientAmount,
+  insufficientAmount1,
 ) where
 
 import Agora.Governor (Governor (..))
@@ -17,6 +36,7 @@ import Agora.Proposal (
   ProposalId (ProposalId),
   ProposalRedeemer (Vote),
   ProposalStatus (VotingReady),
+  ProposalThresholds (vote),
   ProposalVotes (ProposalVotes),
   ResultTag (ResultTag),
  )
@@ -24,269 +44,550 @@ import Agora.Proposal.Time (
   ProposalStartingTime (ProposalStartingTime),
   ProposalTimingConfig (draftTime, votingTime),
  )
-import Agora.Scripts (AgoraScripts (..))
+import Agora.SafeMoney (GTTag)
 import Agora.Stake (
-  ProposalLock (..),
+  ProposalAction (Voted),
+  ProposalLock (ProposalLock),
   StakeDatum (..),
-  StakeRedeemer (PermitVote),
+  StakeRedeemer (Destroy, PermitVote),
  )
 import Data.Default (Default (def))
-import Data.Tagged (Tagged (Tagged), untag)
+import Data.Map.Strict qualified as StrictMap
+import Data.Maybe (catMaybes)
+import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
   input,
+  mint,
+  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
-  txId,
-  withDatum,
-  withOutRef,
+  withInlineDatum,
+  withRedeemer,
+  withRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  PubKeyHash,
-  TxOutRef (TxOutRef),
- )
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusTx.AssocMap qualified as AssocMap
-import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
+import Plutarch.Extra.AssetClass (adaClass, assetClassValue)
+import PlutusLedgerApi.V2 (Credential (PubKeyCredential), Interval, POSIXTime, PubKeyHash)
+import PlutusLedgerApi.V2.Contexts (TxOutRef (TxOutRef))
+import Sample.Proposal.Shared (proposalTxRef)
 import Sample.Shared (
-  agoraScripts,
   governor,
   minAda,
-  proposalPolicySymbol,
-  proposalValidatorHash,
-  signer,
+  proposalAssetClass,
+  proposalScriptHash,
+  proposalValidator,
   stakeAssetClass,
-  stakeValidatorHash,
+  stakeScriptHash,
+  stakeValidator,
  )
-import Test.Specification (
-  SpecificationTree,
-  group,
-  testValidator,
-  validatorSucceedsWith,
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (
+  CombinableBuilder,
+  closedBoundedInterval,
+  mkSpending,
+  pubKeyHashes,
  )
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue, updateMap)
 
--- | Reference to the proposal UTXO.
-proposalRef :: TxOutRef
-proposalRef = TxOutRef proposalTxRef 0
-
--- | Reference to the stake UTXO.
-stakeRef :: TxOutRef
-stakeRef = TxOutRef stakeTxRef 1
-
--- | Parameters for creating a voting transaction.
-data Parameters = Parameters
-  { voteFor :: ResultTag
-  -- ^ The outcome the transaction is voting for.
-  , voteCount :: Integer
-  -- ^ The count of votes.
-  , voteAsDelegate :: Bool
-  -- ^ Delegate the stake and use it to vote.
+data ParameterBundle = ParamerterBundle
+  { voteParameters :: VoteParameters
+  , stakeParameters :: StakeParameters
+  , proposalParameters :: ProposalParameters
+  , transactionParameters :: TransactionParameters
   }
 
--- | The public key hash of the stake owner.
-stakeOwner :: PubKeyHash
-stakeOwner = signer
+newtype VoteParameters = VoteParameters {voteFor :: ResultTag}
 
--- | The votes of the input proposals.
-initialVotes :: AssocMap.Map ResultTag Integer
+data StakeParameters = StakeParameters
+  { numStakes :: Integer
+  , mixInDelegateeAsOwner :: Bool
+  , stakeInputParameters :: StakeInputParameters
+  , stakeOutputParameters :: StakeOutputParameters
+  }
+
+newtype StakeInputParameters = StakeInputParameters
+  { perStakeGTs :: Tagged GTTag Integer
+  }
+
+data StakeOutputParameters = StakeOutputParameters
+  { burnStakes :: Bool
+  , dontAddNewLock :: Bool
+  , changeGTAmount :: Bool
+  , changeAdaAmount :: Bool
+  }
+
+data NumProposals = NoProposal | OneProposal | MoreThanOneProposals
+
+data ProposalParameters = ProposalParameters
+  { wrongAddedVotes :: Bool
+  , numProposals :: NumProposals
+  }
+
+data SignedBy = Owner | Delegatee | Unknown
+
+newtype TransactionParameters = TransactionParameters
+  { signedBy :: SignedBy
+  }
+
+data Validity = Validity
+  { forProposalValidator :: Bool
+  , forStakeValidator :: Bool
+  }
+
+--------------------------------------------------------------------------------
+
+stakeOwner :: PubKeyHash
+stakeOwner = head pubKeyHashes
+
+delegatee :: PubKeyHash
+delegatee = pubKeyHashes !! 1
+
+unknownSig :: PubKeyHash
+unknownSig = pubKeyHashes !! 2
+
+validTimeRangeLowerBound :: POSIXTime
+validTimeRangeLowerBound =
+  0
+    + (def :: ProposalTimingConfig).draftTime
+    + 1
+
+validTimeRangeUpperBound :: POSIXTime
+validTimeRangeUpperBound =
+  validTimeRangeLowerBound
+    + (def :: ProposalTimingConfig).votingTime
+    - 2
+
+validTimeRange :: Interval POSIXTime
+validTimeRange =
+  closedBoundedInterval
+    validTimeRangeLowerBound
+    validTimeRangeUpperBound
+
+--------------------------------------------------------------------------------
+
+initialVotes :: StrictMap.Map ResultTag Integer
 initialVotes =
-  AssocMap.fromList
-    [ (ResultTag 0, 42)
-    , (ResultTag 1, 4242)
+  StrictMap.fromList
+    [ (ResultTag 0, 114)
+    , (ResultTag 1, 514)
     ]
 
--- | The input proposal datum.
 proposalInputDatum :: ProposalDatum
 proposalInputDatum =
   ProposalDatum
-    { proposalId = ProposalId 42
+    { proposalId = ProposalId 22
     , effects =
-        AssocMap.fromList
-          [ (ResultTag 0, AssocMap.empty)
-          , (ResultTag 1, AssocMap.empty)
+        StrictMap.fromList
+          [ (ResultTag 0, StrictMap.empty)
+          , (ResultTag 1, StrictMap.empty)
           ]
     , status = VotingReady
-    , cosigners = [stakeOwner]
+    , cosigners = [PubKeyCredential stakeOwner]
     , thresholds = def
     , votes = ProposalVotes initialVotes
     , timingConfig = def
     , startingTime = ProposalStartingTime 0
     }
 
--- | The locks of the input stake.
-existingLocks :: [ProposalLock]
-existingLocks =
-  [ Voted (ProposalId 0) (ResultTag 0)
-  , Voted (ProposalId 1) (ResultTag 2)
-  ]
+mkProposalRedeemer :: VoteParameters -> ProposalRedeemer
+mkProposalRedeemer v = Vote v.voteFor
 
-delegate :: PubKeyHash
-delegate = head pubKeyHashes
+mkProposalRef :: Integer -> TxOutRef
+mkProposalRef = TxOutRef proposalTxRef
 
-{- | Set the 'StakeDatum.stakedAmount' according to the number of votes being
-      casted.
--}
-mkStakeInputDatum :: Parameters -> StakeDatum
+numProposals :: NumProposals -> Integer
+numProposals NoProposal = 0
+numProposals OneProposal = 1
+numProposals MoreThanOneProposals = 2
+
+--------------------------------------------------------------------------------
+
+mkStakeRedeemer :: StakeOutputParameters -> StakeRedeemer
+mkStakeRedeemer params =
+  if params.burnStakes
+    then Destroy
+    else PermitVote
+
+mkStakeInputDatum :: StakeInputParameters -> StakeDatum
 mkStakeInputDatum params =
   StakeDatum
-    { stakedAmount = Tagged params.voteCount
-    , owner = stakeOwner
-    , delegatedTo =
-        if params.voteAsDelegate
-          then Just delegate
-          else Nothing
-    , lockedBy = existingLocks
+    { stakedAmount = params.perStakeGTs
+    , owner = PubKeyCredential stakeOwner
+    , delegatedTo = Just (PubKeyCredential delegatee)
+    , lockedBy =
+        [ ProposalLock (ProposalId 0) $ Voted (ResultTag 0) 100
+        , ProposalLock (ProposalId 1) $ Voted (ResultTag 2) 200
+        ]
     }
 
--- | Create the proposal redeemer. In this case @'Vote' _@ will always be used.
-mkProposalRedeemer :: Parameters -> ProposalRedeemer
-mkProposalRedeemer = Vote . voteFor
+mkStakeRef :: Integer -> Integer -> TxOutRef
+mkStakeRef o i = TxOutRef proposalTxRef $ o + i
 
--- | Place new proposal locks on the stake.
-mkNewLock :: Parameters -> ProposalLock
-mkNewLock = Voted proposalInputDatum.proposalId . voteFor
+--------------------------------------------------------------------------------
 
-{- | The stake redeemer that is used in 'mkTestTree'. In this case it'll always be
-      'PermitVote'.
--}
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = PermitVote
-
--- | Create a valid transaction that votes on a propsal, given the parameters.
-vote :: forall b. CombinableBuilder b => Parameters -> b
+vote :: forall b. CombinableBuilder b => ParameterBundle -> b
 vote params =
-  let pst = Value.singleton proposalPolicySymbol "" 1
-      sst = Value.assetClassValue stakeAssetClass 1
+  let pst = assetClassValue proposalAssetClass 1
+      sst = assetClassValue stakeAssetClass 1
 
       ---
 
-      stakeInputDatum = mkStakeInputDatum params
+      stakeInputDatum =
+        mkStakeInputDatum
+          params.stakeParameters.stakeInputParameters
 
-      ---
+      stakeInputValue =
+        normalizeValue $
+          sst
+            <> assetClassValue
+              governor.gtClassRef
+              params.stakeParameters.stakeInputParameters.perStakeGTs
+            <> minAda
 
-      updatedVotes :: AssocMap.Map ResultTag Integer
-      updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
+      newLock =
+        ProposalLock
+          proposalInputDatum.proposalId
+          $ Voted
+            params.voteParameters.voteFor
+            validTimeRangeUpperBound
 
-      ---
+      updatedLocks =
+        if params.stakeParameters.stakeOutputParameters.dontAddNewLock
+          then stakeInputDatum.lockedBy
+          else newLock : stakeInputDatum.lockedBy
+
+      stakeOutputDatum = stakeInputDatum {lockedBy = updatedLocks}
+
+      stakeOutputValue =
+        let changeAmount cond = if cond then (* 100) else id
+            gtAmount =
+              changeAmount
+                params.stakeParameters.stakeOutputParameters.changeGTAmount
+                params.stakeParameters.stakeInputParameters.perStakeGTs
+            adaAmount =
+              changeAmount
+                params.stakeParameters.stakeOutputParameters.changeAdaAmount
+                10_000_000
+         in normalizeValue $
+              sst
+                <> assetClassValue
+                  governor.gtClassRef
+                  gtAmount
+                <> minAda
+                <> assetClassValue adaClass adaAmount
+
+      stakeRedeemer =
+        mkStakeRedeemer params.stakeParameters.stakeOutputParameters
+
+      mixOwner i datum =
+        if params.stakeParameters.mixInDelegateeAsOwner
+          && i == 2
+          then
+            datum
+              { owner = PubKeyCredential delegatee
+              , delegatedTo = Nothing
+              }
+          else datum
+
+      stakeBuilder :: b
+      stakeBuilder =
+        foldMap
+          ( \i ->
+              mconcat
+                [ input $
+                    mconcat
+                      [ script stakeScriptHash
+                      , withValue stakeInputValue
+                      , withInlineDatum $ mixOwner i stakeInputDatum
+                      , withRedeemer stakeRedeemer
+                      , withRef $ mkStakeRef numProposals' i
+                      ]
+                , if params.stakeParameters.stakeOutputParameters.burnStakes
+                    then mint $ assetClassValue stakeAssetClass (-1)
+                    else
+                      output $
+                        mconcat
+                          [ script stakeScriptHash
+                          , withValue stakeOutputValue
+                          , withInlineDatum $ mixOwner i stakeOutputDatum
+                          ]
+                ]
+          )
+          [1 .. params.stakeParameters.numStakes]
+
+      --------------------------------------------------------------------------
+
+      numProposals' = numProposals params.proposalParameters.numProposals
+
+      updatedVotes =
+        StrictMap.adjust
+          ( ( if params.proposalParameters.wrongAddedVotes
+                then (* 10)
+                else id
+            )
+              . ( +
+                    untag params.stakeParameters.stakeInputParameters.perStakeGTs
+                      * params.stakeParameters.numStakes
+                )
+          )
+          params.voteParameters.voteFor
+          initialVotes
 
-      proposalOutputDatum :: ProposalDatum
       proposalOutputDatum =
         proposalInputDatum
           { votes = ProposalVotes updatedVotes
           }
 
-      ---
+      proposalRedeemer = mkProposalRedeemer params.voteParameters
 
-      -- Off-chain code should do exactly like this: prepend new lock toStatus the list.
-      updatedLocks :: [ProposalLock]
-      updatedLocks = mkNewLock params : existingLocks
-
-      ---
-
-      stakeOutputDatum :: StakeDatum
-      stakeOutputDatum =
-        stakeInputDatum
-          { lockedBy = updatedLocks
-          }
-
-      ---
-
-      validTimeRange =
-        closedBoundedInterval
-          ((def :: ProposalTimingConfig).draftTime + 1)
-          ((def :: ProposalTimingConfig).votingTime - 1)
-
-      ---
-
-      stakeValue =
-        sortValue $
-          sst
-            <> Value.assetClassValue (untag governor.gtClassRef) params.voteCount
+      proposalValue =
+        normalizeValue $
+          pst
             <> minAda
 
-      signer =
-        if params.voteAsDelegate
-          then delegate
-          else stakeOwner
+      proposalBuidler :: b
+      proposalBuidler =
+        foldMap
+          ( \i ->
+              mconcat
+                [ input $
+                    mconcat
+                      [ script proposalScriptHash
+                      , withValue proposalValue
+                      , withRedeemer proposalRedeemer
+                      , withInlineDatum proposalInputDatum
+                      , withRef $ mkProposalRef i
+                      ]
+                , output $
+                    mconcat
+                      [ script proposalScriptHash
+                      , withValue proposalValue
+                      , withInlineDatum proposalOutputDatum
+                      ]
+                ]
+          )
+          [1 .. numProposals']
 
+      --------------------------------------------------------------------------
+
+      sig = case params.transactionParameters.signedBy of
+        Owner -> stakeOwner
+        Delegatee -> delegatee
+        Unknown -> unknownSig
+
+      --------------------------------------------------------------------------
+
+      miscBuilder :: b
+      miscBuilder =
+        mconcat
+          [ signedWith sig
+          , timeRange validTimeRange
+          ]
+
+      --------------------------------------------------------------------------
+
+      builder :: b
       builder =
         mconcat
-          [ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
-          , signedWith signer
-          , timeRange validTimeRange
-          , input $
-              mconcat
-                [ script proposalValidatorHash
-                , withValue pst
-                , withDatum proposalInputDatum
-                , withOutRef proposalRef
-                ]
-          , input $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum stakeInputDatum
-                , withOutRef stakeRef
-                ]
-          , output $
-              mconcat
-                [ script proposalValidatorHash
-                , withValue pst
-                , withDatum proposalOutputDatum
-                ]
-          , output $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum stakeOutputDatum
-                ]
+          [ stakeBuilder
+          , proposalBuidler
+          , miscBuilder
           ]
    in builder
 
----
+--------------------------------------------------------------------------------
 
--- | Valida parameters that vote on the proposal.
-validVoteParameters :: Parameters
-validVoteParameters =
-  Parameters
-    { voteFor = ResultTag 0
-    , voteCount = 27
-    , voteAsDelegate = False
-    }
-
-validVoteAsDelegateParameters :: Parameters
-validVoteAsDelegateParameters =
-  validVoteParameters
-    { voteAsDelegate = True
-    }
-
----
-
-{- | Create a test tree that runs the stake validator and proposal validator to
-      test the voting functionalities.
--}
-mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
-mkTestTree name ps isValid = group name [proposal, stake]
+mkTestTree :: String -> ParameterBundle -> Validity -> SpecificationTree
+mkTestTree name ps val = group name $ catMaybes [proposal, stake]
   where
     spend = mkSpending vote ps
 
+    numProposals' = numProposals ps.proposalParameters.numProposals
+
     proposal =
-      testValidator
-        isValid
-        "proposal"
-        agoraScripts.compiledProposalValidator
-        proposalInputDatum
-        (mkProposalRedeemer ps)
-        (spend proposalRef)
+      case ps.proposalParameters.numProposals of
+        NoProposal -> Nothing
+        _ ->
+          Just $
+            testValidator
+              val.forProposalValidator
+              "proposal"
+              proposalValidator
+              proposalInputDatum
+              (mkProposalRedeemer ps.voteParameters)
+              (spend $ mkProposalRef 1)
 
     stake =
-      let stakeInputDatum = mkStakeInputDatum ps
-       in validatorSucceedsWith
-            "stake"
-            agoraScripts.compiledStakeValidator
-            stakeInputDatum
-            stakeRedeemer
-            (spend stakeRef)
+      case ps.stakeParameters.numStakes of
+        0 -> error "At least one stake"
+        _ ->
+          let stakeRef = mkStakeRef numProposals' 1
+           in Just $
+                testValidator
+                  val.forStakeValidator
+                  "stake"
+                  stakeValidator
+                  (mkStakeInputDatum ps.stakeParameters.stakeInputParameters)
+                  (mkStakeRedeemer ps.stakeParameters.stakeOutputParameters)
+                  (spend stakeRef)
+
+--------------------------------------------------------------------------------
+
+-- TODO(Connor) Use optics
+
+mkValidOwnerVoteBundle :: Integer -> ParameterBundle
+mkValidOwnerVoteBundle stakes =
+  ParamerterBundle
+    { voteParameters =
+        VoteParameters
+          { voteFor = ResultTag 0
+          }
+    , stakeParameters =
+        StakeParameters
+          { numStakes = stakes
+          , mixInDelegateeAsOwner = False
+          , stakeInputParameters =
+              StakeInputParameters
+                { perStakeGTs = (def :: ProposalThresholds).vote
+                }
+          , stakeOutputParameters =
+              StakeOutputParameters
+                { burnStakes = False
+                , dontAddNewLock = False
+                , changeGTAmount = False
+                , changeAdaAmount = False
+                }
+          }
+    , proposalParameters =
+        ProposalParameters
+          { wrongAddedVotes = False
+          , numProposals = OneProposal
+          }
+    , transactionParameters =
+        TransactionParameters
+          { signedBy = Owner
+          }
+    }
+
+mkValidDelegateeVoteBundle :: Integer -> ParameterBundle
+mkValidDelegateeVoteBundle stakes =
+  let template = mkValidOwnerVoteBundle stakes
+   in template
+        { transactionParameters =
+            template.transactionParameters
+              { signedBy = Delegatee
+              }
+        }
+
+delegateeVoteWithOwnAndDelegatedStakeBundle :: ParameterBundle
+delegateeVoteWithOwnAndDelegatedStakeBundle =
+  let template = mkValidDelegateeVoteBundle 5
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { mixInDelegateeAsOwner = True
+              }
+        }
+
+ownerVoteWithSignleStake :: ParameterBundle
+ownerVoteWithSignleStake = mkValidOwnerVoteBundle 1
+
+transparentAssets :: ParameterBundle
+transparentAssets =
+  ownerVoteWithSignleStake
+    { stakeParameters =
+        ownerVoteWithSignleStake.stakeParameters
+          { stakeOutputParameters =
+              ownerVoteWithSignleStake.stakeParameters.stakeOutputParameters
+                { changeAdaAmount = True
+                }
+          }
+    }
+
+transactionNotAuthorized :: ParameterBundle
+transactionNotAuthorized =
+  ownerVoteWithSignleStake
+    { transactionParameters =
+        ownerVoteWithSignleStake.transactionParameters
+          { signedBy = Unknown
+          }
+    }
+
+voteForNonexistentOutcome :: ParameterBundle
+voteForNonexistentOutcome =
+  ownerVoteWithSignleStake
+    { voteParameters =
+        ownerVoteWithSignleStake.voteParameters
+          { voteFor = ResultTag 1919810
+          }
+    }
+
+noProposal :: ParameterBundle
+noProposal =
+  ownerVoteWithSignleStake
+    { proposalParameters =
+        ownerVoteWithSignleStake.proposalParameters
+          { numProposals = NoProposal
+          }
+    }
+
+moreThanOneProposals :: ParameterBundle
+moreThanOneProposals =
+  ownerVoteWithSignleStake
+    { proposalParameters =
+        ownerVoteWithSignleStake.proposalParameters
+          { numProposals = MoreThanOneProposals
+          }
+    }
+
+ownerVoteWithMultipleStakes :: ParameterBundle
+ownerVoteWithMultipleStakes = mkValidOwnerVoteBundle 5
+
+invalidLocks :: ParameterBundle
+invalidLocks =
+  ownerVoteWithMultipleStakes
+    { stakeParameters =
+        ownerVoteWithMultipleStakes.stakeParameters
+          { stakeOutputParameters =
+              ownerVoteWithMultipleStakes.stakeParameters.stakeOutputParameters
+                { dontAddNewLock = True
+                }
+          }
+    }
+
+destroyStakes :: ParameterBundle
+destroyStakes =
+  ownerVoteWithMultipleStakes
+    { stakeParameters =
+        ownerVoteWithMultipleStakes.stakeParameters
+          { stakeOutputParameters =
+              ownerVoteWithMultipleStakes.stakeParameters.stakeOutputParameters
+                { burnStakes = True
+                }
+          }
+    }
+
+insufficientAmount :: ParameterBundle
+insufficientAmount =
+  ownerVoteWithSignleStake
+    { stakeParameters =
+        ownerVoteWithSignleStake.stakeParameters
+          { stakeInputParameters =
+              ownerVoteWithSignleStake.stakeParameters.stakeInputParameters
+                { perStakeGTs = 1
+                }
+          }
+    }
+
+insufficientAmount1 :: ParameterBundle
+insufficientAmount1 =
+  ownerVoteWithMultipleStakes
+    { stakeParameters =
+        ownerVoteWithMultipleStakes.stakeParameters
+          { stakeInputParameters =
+              ownerVoteWithMultipleStakes.stakeParameters.stakeInputParameters
+                { perStakeGTs = 1
+                }
+          }
+    }

agora-specs/Sample/Shared.hs

@@ -12,8 +12,8 @@ module Sample.Shared (
   signer,
   signer2,
   minAda,
-  deterministicTracingConfing,
-  mkEffect,
+  deterministicTracingConfig,
+  mkRedeemer,
 
   -- * Agora Scripts
   agoraScripts,
@@ -22,27 +22,33 @@ module Sample.Shared (
 
   -- ** Stake
   stakeAssetClass,
-  stakeValidatorHash,
+  stakePolicy,
+  stakeValidator,
+  stakeScriptHash,
   stakeAddress,
   stakeSymbol,
 
   -- ** Governor
   governor,
-  govPolicy,
-  govValidator,
-  govSymbol,
-  govAssetClass,
-  govValidatorAddress,
-  govValidatorHash,
+  governorPolicy,
+  governorValidator,
+  governorSymbol,
+  governorAssetClass,
+  governorValidatorAddress,
+  governorScriptHash,
   gstUTXORef,
 
   -- ** Proposal
+  proposalPolicy,
   proposalPolicySymbol,
-  proposalValidatorHash,
+  proposalValidator,
+  proposalScriptHash,
   proposalValidatorAddress,
   proposalStartingTimeFromTimeRange,
+  proposalAssetClass,
 
   -- ** Authority
+  authorityTokenPolicy,
   authorityTokenSymbol,
 
   -- ** Treasury
@@ -51,65 +57,67 @@ module Sample.Shared (
   gatCs,
   mockTrEffect,
   mockTrEffectHash,
+  trValidator,
+  trScriptHash,
   trCredential,
   wrongEffHash,
 ) where
 
 import Agora.Bootstrap qualified as Bootstrap
-import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (Governor (Governor))
+import Agora.Linker (linker)
 import Agora.Proposal (ProposalThresholds (..))
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (..),
   ProposalStartingTime (ProposalStartingTime),
   ProposalTimingConfig (..),
  )
-import Agora.Scripts qualified as Scripts
-import Agora.Treasury (treasuryValidator)
-import Agora.Utils (
-  CompiledEffect (CompiledEffect),
-  CompiledMintingPolicy (getCompiledMintingPolicy),
-  CompiledValidator (getCompiledValidator),
-  validatorHashToTokenName,
- )
+import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
 import Data.Default.Class (Default (..))
+import Data.Map (Map, (!))
 import Data.Tagged (Tagged (..))
-import Plutarch (Config (..), TracingMode (DetTracing))
-import Plutarch.Api.V1 (
-  PValidator,
-  mintingPolicySymbol,
-  mkValidator,
-  validatorHash,
+import Data.Text (Text)
+import Optics (view)
+import Plutarch (Config (..), Script, TracingMode (DetTracing))
+import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Address (scriptHashAddress)
+import PlutusLedgerApi.V1.Value (TokenName, Value)
+import PlutusLedgerApi.V1.Value qualified as Value (
+  singleton,
  )
-import PlutusLedgerApi.V1 (
+import PlutusLedgerApi.V2 (
   Address (Address),
   Credential (ScriptCredential),
-  CurrencySymbol,
+  CurrencySymbol (CurrencySymbol),
   Extended (..),
   Interval (..),
   LowerBound (..),
-  MintingPolicy (..),
+  OutputDatum (NoOutputDatum),
   POSIXTimeRange,
   PubKeyHash,
+  Redeemer (..),
+  ScriptHash (getScriptHash),
+  ToData (toBuiltinData),
+  TxOut (
+    TxOut,
+    txOutAddress,
+    txOutDatum,
+    txOutReferenceScript,
+    txOutValue
+  ),
   TxOutRef (TxOutRef),
   UpperBound (..),
-  Value,
- )
-import PlutusLedgerApi.V1.Address (scriptHashAddress)
-import PlutusLedgerApi.V1.Contexts (TxOut (..))
-import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..))
-import PlutusLedgerApi.V1.Value (AssetClass, TokenName)
-import PlutusLedgerApi.V1.Value qualified as Value (
-  assetClass,
-  singleton,
  )
 import PlutusTx qualified
+import ScriptExport.ScriptInfo (runLinker)
 
 -- Plutarch compiler configauration.
 -- TODO: add the ability to change this value. Maybe wrap everything in a
 --        Reader monad?
-deterministicTracingConfing :: Config
-deterministicTracingConfing = Config DetTracing
+deterministicTracingConfig :: Config
+deterministicTracingConfig = Config DetTracing
 
 governor :: Governor
 governor = Governor oref gt mc
@@ -117,49 +125,69 @@ governor = Governor oref gt mc
     oref = gstUTXORef
     gt =
       Tagged $
-        Value.assetClass
+        AssetClass
           "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
           "LQ"
     mc = 20
 
-agoraScripts :: Scripts.AgoraScripts
-agoraScripts = Bootstrap.agoraScripts deterministicTracingConfing governor
+agoraScripts :: Map Text Script
+agoraScripts =
+  either
+    (error . show)
+    (fmap (view #script) . view #scripts)
+    ( runLinker
+        linker
+        (Bootstrap.agoraScripts deterministicTracingConfig)
+        governor
+    )
+
+stakePolicy :: Script
+stakePolicy = agoraScripts ! "agora:stakePolicy"
 
 stakeSymbol :: CurrencySymbol
-stakeSymbol = Scripts.stakeSTSymbol agoraScripts
+stakeSymbol = CurrencySymbol . getScriptHash $ scriptHash stakePolicy
 
-stakeAssetClass :: AssetClass
-stakeAssetClass = Scripts.stakeSTAssetClass agoraScripts
+stakeAssetClass :: Tagged StakeSTTag AssetClass
+stakeAssetClass = Tagged $ AssetClass stakeSymbol (scriptHashToTokenName stakeScriptHash)
 
-stakeValidatorHash :: ValidatorHash
-stakeValidatorHash = Scripts.stakeValidatorHash agoraScripts
+stakeValidator :: Script
+stakeValidator = agoraScripts ! "agora:stakeValidator"
+
+stakeScriptHash :: ScriptHash
+stakeScriptHash = scriptHash stakeValidator
 
 stakeAddress :: Address
-stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+stakeAddress = Address (ScriptCredential stakeScriptHash) Nothing
 
 gstUTXORef :: TxOutRef
 gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
 
-govPolicy :: MintingPolicy
-govPolicy = getCompiledMintingPolicy $ agoraScripts.compiledGovernorPolicy
+governorPolicy :: Script
+governorPolicy = agoraScripts ! "agora:governorPolicy"
 
-govValidator :: Validator
-govValidator = getCompiledValidator $ agoraScripts.compiledGovernorValidator
+governorValidator :: Script
+governorValidator = agoraScripts ! "agora:governorValidator"
 
-govSymbol :: CurrencySymbol
-govSymbol = mintingPolicySymbol govPolicy
+governorSymbol :: CurrencySymbol
+governorSymbol = CurrencySymbol . getScriptHash $ scriptHash governorPolicy
 
-govAssetClass :: AssetClass
-govAssetClass = Scripts.governorSTAssetClass agoraScripts
+governorAssetClass :: Tagged GovernorSTTag AssetClass
+governorAssetClass = Tagged $ AssetClass governorSymbol ""
 
-govValidatorHash :: ValidatorHash
-govValidatorHash = Scripts.governorValidatorHash agoraScripts
+governorScriptHash :: ScriptHash
+governorScriptHash = scriptHash governorValidator
 
-govValidatorAddress :: Address
-govValidatorAddress = scriptHashAddress govValidatorHash
+governorValidatorAddress :: Address
+governorValidatorAddress = scriptHashAddress governorScriptHash
+
+proposalPolicy :: Script
+proposalPolicy = agoraScripts ! "agora:proposalPolicy"
 
 proposalPolicySymbol :: CurrencySymbol
-proposalPolicySymbol = Scripts.proposalSTSymbol agoraScripts
+proposalPolicySymbol = CurrencySymbol . getScriptHash $ scriptHash proposalPolicy
+
+proposalAssetClass :: Tagged ProposalSTTag AssetClass
+proposalAssetClass = Tagged $ AssetClass proposalPolicySymbol ""
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -169,11 +197,14 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 signer2 :: PubKeyHash
 signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
 
-proposalValidatorHash :: ValidatorHash
-proposalValidatorHash = Scripts.proposalValidatoHash agoraScripts
+proposalValidator :: Script
+proposalValidator = agoraScripts ! "agora:proposalValidator"
+
+proposalScriptHash :: ScriptHash
+proposalScriptHash = scriptHash proposalValidator
 
 proposalValidatorAddress :: Address
-proposalValidatorAddress = scriptHashAddress proposalValidatorHash
+proposalValidatorAddress = scriptHashAddress proposalScriptHash
 
 {- | Default value of 'Agora.Proposal.ProposalThresholds'.
      For testing purpose only.
@@ -183,11 +214,16 @@ instance Default ProposalThresholds where
     ProposalThresholds
       { execute = Tagged 1000
       , create = Tagged 1
+      , toVoting = Tagged 100
       , vote = Tagged 100
+      , cosign = Tagged 100
       }
 
+authorityTokenPolicy :: Script
+authorityTokenPolicy = agoraScripts ! "agora:authorityTokenPolicy"
+
 authorityTokenSymbol :: CurrencySymbol
-authorityTokenSymbol = Scripts.authorityTokenSymbol agoraScripts
+authorityTokenSymbol = CurrencySymbol . getScriptHash $ scriptHash authorityTokenPolicy
 
 {- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
      For testing purpose only.
@@ -199,6 +235,8 @@ instance Default ProposalTimingConfig where
       , votingTime = 1000
       , lockingTime = 2000
       , executingTime = 3000
+      , minStakeVotingTime = 100
+      , votingTimeRangeMaxWidth = 1000000
       }
 
 {- | Default value of 'Agora.Governor.GovernorDatum.createProposalTimeRangeMaxWidth'.
@@ -216,8 +254,8 @@ proposalStartingTimeFromTimeRange
     ProposalStartingTime $ (l + u) `div` 2
 proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed"
 
-mkEffect :: (PlutusTx.ToData datum) => ClosedTerm PValidator -> CompiledEffect datum
-mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
+mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer
+mkRedeemer = Redeemer . toBuiltinData
 
 ------------------------------------------------------------------
 
@@ -226,41 +264,43 @@ treasuryOut =
   TxOut
     { txOutAddress = Address trCredential Nothing
     , txOutValue = minAda
-    , txOutDatumHash = Nothing
+    , txOutDatum = NoOutputDatum
+    , txOutReferenceScript = Nothing
     }
 
 {- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
      of a valid governance authority token (GAT).
 -}
 gatCs :: CurrencySymbol
-gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+gatCs = authorityTokenSymbol
 
-trValidator :: Validator
-trValidator = mkValidator def (treasuryValidator gatCs)
+trValidator :: Script
+trValidator = agoraScripts ! "agora:treasuryValidator"
+
+trScriptHash :: ScriptHash
+trScriptHash = scriptHash trValidator
 
 -- | `ScriptCredential` used for the dummy treasury validator.
 trCredential :: Credential
-trCredential = ScriptCredential $ validatorHash trValidator
+trCredential = ScriptCredential trScriptHash
 
 -- | `TokenName` for GAT generated from address of `mockTrEffect`.
 gatTn :: TokenName
-gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
+gatTn = scriptHashToTokenName $ scriptHash mockTrEffect
 
 -- | Mock treasury effect script, used for testing.
-mockTrEffect :: Validator
-mockTrEffect = mkValidator def $ noOpValidator gatCs
+mockTrEffect :: Script
+mockTrEffect = agoraScripts ! "agora:noOpValidator"
 
 -- | Mock treasury effect validator hash
-mockTrEffectHash :: ValidatorHash
-mockTrEffectHash = validatorHash mockTrEffect
+mockTrEffectHash :: ScriptHash
+mockTrEffectHash = scriptHash mockTrEffect
 
 {- | A SHA-256 hash which (in all certainty) should not match the
      hash of the dummy effect script.
 -}
-wrongEffHash :: ValidatorHash
-wrongEffHash =
-  ValidatorHash
-    "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
+wrongEffHash :: ScriptHash
+wrongEffHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
 
 ------------------------------------------------------------------
 

agora-specs/Sample/Stake.hs

@@ -11,9 +11,6 @@ module Sample.Stake (
   signer,
 
   -- * Script contexts
-  stakeCreation,
-  stakeCreationWrongDatum,
-  stakeCreationUnsigned,
   stakeDepositWithdraw,
   DepositWithdrawExample (..),
 ) where
@@ -23,91 +20,35 @@ import Agora.SafeMoney (GTTag)
 import Agora.Stake (
   StakeDatum (StakeDatum, stakedAmount),
  )
-import Data.Tagged (Tagged, untag)
+import Data.Tagged (Tagged)
 import Plutarch.Context (
-  MintingBuilder,
   SpendingBuilder,
-  buildMintingUnsafe,
-  buildSpendingUnsafe,
+  buildSpending',
   input,
-  mint,
   output,
   script,
   signedWith,
   txId,
   withDatum,
-  withMinting,
-  withOutRef,
+  withRef,
   withSpendingOutRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  Datum (Datum),
-  ScriptContext (..),
-  ScriptPurpose (Minting),
-  ToData (toBuiltinData),
-  TxInfo (txInfoData, txInfoSignatories),
- )
+import Plutarch.Extra.AssetClass (assetClassValue)
 import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
-import PlutusLedgerApi.V1.Value qualified as Value (
-  assetClassValue,
-  singleton,
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
+  ScriptContext (..),
  )
 import Sample.Shared (
   governor,
   signer,
   stakeAssetClass,
+  stakeScriptHash,
   stakeSymbol,
-  stakeValidatorHash,
  )
 import Test.Util (sortValue)
 
--- | This script context should be a valid transaction.
-stakeCreation :: ScriptContext
-stakeCreation =
-  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
-      datum :: StakeDatum
-      datum = StakeDatum 424242424242 signer Nothing []
-
-      builder :: MintingBuilder
-      builder =
-        mconcat
-          [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-          , signedWith signer
-          , mint st
-          , output $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
-                , withDatum datum
-                ]
-          , withMinting stakeSymbol
-          ]
-   in buildMintingUnsafe builder
-
--- | This ScriptContext should fail because the datum has too much GT.
-stakeCreationWrongDatum :: ScriptContext
-stakeCreationWrongDatum =
-  let datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer Nothing []) -- Too much GT
-   in ScriptContext
-        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
-        , scriptContextPurpose = Minting stakeSymbol
-        }
-
--- | This ScriptContext should fail because the datum has too much GT.
-stakeCreationUnsigned :: ScriptContext
-stakeCreationUnsigned =
-  ScriptContext
-    { scriptContextTxInfo =
-        stakeCreation.scriptContextTxInfo
-          { txInfoSignatories = []
-          }
-    , scriptContextPurpose = Minting stakeSymbol
-    }
-
---------------------------------------------------------------------------------
-
 -- | Config for creating a ScriptContext that deposits or withdraws.
 data DepositWithdrawExample = DepositWithdrawExample
   { startAmount :: Tagged GTTag Integer
@@ -119,9 +60,9 @@ data DepositWithdrawExample = DepositWithdrawExample
 -- | Create a ScriptContext that deposits or withdraws, given the config for it.
 stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
-  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
+  let st = assetClassValue stakeAssetClass 1 -- Stake ST
       stakeBefore :: StakeDatum
-      stakeBefore = StakeDatum config.startAmount signer Nothing []
+      stakeBefore = StakeDatum config.startAmount (PubKeyCredential signer) Nothing []
 
       stakeAfter :: StakeDatum
       stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
@@ -134,28 +75,27 @@ stakeDepositWithdraw config =
         mconcat
           [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
           , signedWith signer
-          , mint st
           , input $
               mconcat
-                [ script stakeValidatorHash
+                [ script stakeScriptHash
                 , withValue
                     ( sortValue $
                         st
-                          <> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount)
+                          <> assetClassValue governor.gtClassRef stakeBefore.stakedAmount
                     )
-                , withDatum stakeAfter
-                , withOutRef stakeRef
+                , withDatum stakeBefore
+                , withRef stakeRef
                 ]
           , output $
               mconcat
-                [ script stakeValidatorHash
+                [ script stakeScriptHash
                 , withValue
                     ( sortValue $
                         st
-                          <> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount)
+                          <> assetClassValue governor.gtClassRef stakeAfter.stakedAmount
                     )
                 , withDatum stakeAfter
                 ]
           , withSpendingOutRef stakeRef
           ]
-   in buildSpendingUnsafe builder
+   in buildSpending' builder

agora-specs/Sample/Stake/Create.hs

@@ -0,0 +1,260 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Sample.Stake.Create (
+  StakeDatumWrapper (..),
+  Parameters (..),
+  create,
+  mkTestCase,
+  ownerIsPubKeyTotallyValid,
+  ownerIsScriptTotallyValid,
+  createMoreThanOneStake,
+  spendStake,
+  unexpectedStakedAmount,
+  noStakeDatum,
+  malformedStakeDatum,
+  notAuthorizedByOwner,
+  setDelegatee,
+  alreadyHasLocks,
+) where
+
+import Agora.Governor (Governor (gtClassRef))
+import Agora.Proposal (ProposalId (ProposalId))
+import Agora.SafeMoney (GTTag)
+import Agora.Stake (ProposalAction (Created), ProposalLock (ProposalLock), StakeDatum (..))
+import Data.Semigroup (stimesMonoid)
+import Data.Tagged (Tagged)
+import Plutarch.Context (
+  input,
+  mint,
+  normalizeValue,
+  output,
+  pubKey,
+  script,
+  signedWith,
+  withDatum,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  Credential (
+    PubKeyCredential,
+    ScriptCredential
+  ),
+ )
+import Sample.Shared (
+  governor,
+  signer,
+  signer2,
+  stakePolicy,
+  stakeScriptHash,
+  stakeSymbol,
+ )
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
+
+data StakeDatumWrapper
+  = forall (b :: Type) (p :: S -> Type).
+    (PUnsafeLiftDecl p, PLifted p ~ b, PIsData p) =>
+    StakeDatumWrapper b
+
+data Parameters = Parameters
+  { numSSTMinted :: Integer
+  , invalidSSTName :: Bool
+  , stakeAtInput :: Bool
+  , numGTsInValue :: Tagged GTTag Integer
+  , stakeDatum :: Maybe StakeDatumWrapper
+  , authorizedBy :: Maybe Credential
+  }
+
+create :: forall b. CombinableBuilder b => Parameters -> b
+create ps@Parameters {stakeDatum} =
+  let perStakeGTs =
+        assetClassValue
+          governor.gtClassRef
+          ps.numGTsInValue
+
+      gtValue =
+        stimesMonoid ps.numSSTMinted perStakeGTs
+
+      gtInputBuilder =
+        mconcat
+          [ input $
+              mconcat
+                [ pubKey signer
+                , withValue $ normalizeValue gtValue
+                ]
+          ]
+
+      ---
+
+      sstName =
+        if ps.invalidSSTName
+          then "114514"
+          else scriptHashToTokenName stakeScriptHash
+
+      sst = Value.singleton stakeSymbol sstName 1
+
+      withStakeDatum =
+        maybe
+          mempty
+          (\(StakeDatumWrapper stakeDatum) -> withDatum stakeDatum)
+          stakeDatum
+
+      stakeBuilder =
+        mconcat
+          [ script stakeScriptHash
+          , withValue $ normalizeValue $ sst <> perStakeGTs
+          , withStakeDatum
+          ]
+
+      stakeInputBuilder =
+        if ps.stakeAtInput
+          then input stakeBuilder
+          else mempty
+
+      stakeOutputBuilder =
+        stimesMonoid ps.numSSTMinted $
+          output stakeBuilder
+
+      ---
+
+      withAuthorization =
+        maybe
+          mempty
+          ( \case
+              PubKeyCredential pkh -> signedWith pkh
+              ScriptCredential val -> input $ script val
+          )
+          ps.authorizedBy
+
+      ---
+
+      mintSSTs = mint $ stimesMonoid ps.numSSTMinted sst
+   in mconcat
+        [ gtInputBuilder
+        , stakeInputBuilder
+        , stakeOutputBuilder
+        , withAuthorization
+        , mintSSTs
+        ]
+
+mkTestCase :: String -> Parameters -> Bool -> SpecificationTree
+mkTestCase name ps val = stake
+  where
+    mint = mkMinting create ps
+
+    stake =
+      testPolicy
+        val
+        name
+        stakePolicy
+        ()
+        (mint stakeSymbol)
+
+mkTotallyValid :: Integer -> Credential -> Parameters
+mkTotallyValid gts owner =
+  Parameters
+    { numSSTMinted = 1
+    , invalidSSTName = False
+    , numGTsInValue = fromInteger gts
+    , stakeAtInput = False
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = fromInteger gts
+              , owner = owner
+              , delegatedTo = Nothing
+              , lockedBy = []
+              }
+    , authorizedBy = Just owner
+    }
+
+ownerIsPubKeyTotallyValid :: Parameters
+ownerIsPubKeyTotallyValid = mkTotallyValid 114514 (PubKeyCredential signer)
+
+ownerIsScriptTotallyValid :: Parameters
+ownerIsScriptTotallyValid =
+  mkTotallyValid
+    114514
+    ( ScriptCredential $
+        head validatorHashes
+    )
+
+createMoreThanOneStake :: Parameters
+createMoreThanOneStake =
+  ownerIsPubKeyTotallyValid
+    { numSSTMinted = 5
+    }
+
+spendStake :: Parameters
+spendStake =
+  ownerIsPubKeyTotallyValid
+    { stakeAtInput = True
+    }
+
+unexpectedStakedAmount :: Parameters
+unexpectedStakedAmount =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 1919810
+              , owner = PubKeyCredential signer
+              , delegatedTo = Nothing
+              , lockedBy = []
+              }
+    }
+
+noStakeDatum :: Parameters
+noStakeDatum =
+  ownerIsPubKeyTotallyValid
+    { stakeDatum = Nothing
+    }
+
+malformedStakeDatum :: Parameters
+malformedStakeDatum =
+  ownerIsPubKeyTotallyValid
+    { stakeDatum = Just $ StakeDatumWrapper (1 :: Integer)
+    }
+
+notAuthorizedByOwner :: Parameters
+notAuthorizedByOwner =
+  ownerIsPubKeyTotallyValid
+    { authorizedBy = Nothing
+    }
+
+setDelegatee :: Parameters
+setDelegatee =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 114514
+              , owner = PubKeyCredential signer
+              , delegatedTo = Just $ PubKeyCredential signer2
+              , lockedBy = []
+              }
+    }
+
+alreadyHasLocks :: Parameters
+alreadyHasLocks =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 114514
+              , owner = PubKeyCredential signer
+              , delegatedTo = Nothing
+              , lockedBy = [ProposalLock (ProposalId 0) Created]
+              }
+    }

agora-specs/Sample/Stake/Destroy.hs

@@ -0,0 +1,298 @@
+module Sample.Stake.Destroy (
+  ParameterBundle (..),
+  StakeInputParameters (..),
+  StakeBurningParameters (..),
+  LeftOverStakeMode (..),
+  AuthorizedBy (..),
+  Validity (..),
+  destroy,
+  mkTestTree,
+  mkTotallyValid,
+  oneStake,
+  multipleStakes,
+  stealSST,
+  stealSST1,
+  stealSST3,
+  lockedStakes,
+  authorizedByDelegatee,
+  notAuthorized,
+) where
+
+import Agora.Proposal (ProposalId (..))
+import Agora.Stake (
+  ProposalAction (Created),
+  ProposalLock (ProposalLock),
+  StakeDatum (..),
+  StakeRedeemer (Destroy),
+ )
+import Control.Exception (assert)
+import Data.Maybe (catMaybes, fromJust)
+import Data.Semigroup (stimesMonoid)
+import Plutarch.Context (
+  input,
+  mint,
+  normalizeValue,
+  output,
+  pubKey,
+  script,
+  signedWith,
+  withDatum,
+  withRedeemer,
+  withRef,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V1 (
+  Credential (PubKeyCredential),
+  TxOutRef (TxOutRef),
+ )
+import PlutusLedgerApi.V2 (PubKeyHash)
+import Sample.Proposal.Shared (stakeTxRef)
+import Sample.Shared (
+  minAda,
+  signer2,
+  stakeAssetClass,
+  stakePolicy,
+  stakeScriptHash,
+  stakeSymbol,
+  stakeValidator,
+ )
+import Test.Specification (
+  SpecificationTree,
+  group,
+  testPolicy,
+  testValidator,
+ )
+import Test.Util (CombinableBuilder, mkMinting, mkSpending, pubKeyHashes)
+
+data ParameterBundle = ParameterBundle
+  { stakeInputParameters :: StakeInputParameters
+  , stakeBurningParameters :: StakeBurningParameters
+  , authorizedBy :: AuthorizedBy
+  }
+
+data StakeInputParameters = StakeInputParameters
+  { numInputs :: Int
+  , notUnlocked :: Bool
+  }
+
+data StakeBurningParameters = StakeBurningParameters
+  { numBurnt :: Int
+  , leftOverStakeMode :: Maybe LeftOverStakeMode
+  }
+
+data LeftOverStakeMode = OutputAsIs | CollectSSTInOneUTxO
+
+data AuthorizedBy = Owner | Delegatee | NotAuthorized
+
+data Validity = Validity
+  { forStakePolicy :: Maybe Bool
+  , forStakeValidator :: Bool
+  }
+
+--------------------------------------------------------------------------------
+
+owner :: PubKeyHash
+owner = pubKeyHashes !! 2
+
+delegatee :: PubKeyHash
+delegatee = pubKeyHashes !! 3
+
+--------------------------------------------------------------------------------
+
+mkStakeInputDatum :: StakeInputParameters -> StakeDatum
+mkStakeInputDatum ps =
+  StakeDatum
+    { stakedAmount = 114514
+    , owner = PubKeyCredential owner
+    , delegatedTo = Just $ PubKeyCredential delegatee
+    , lockedBy = [ProposalLock (ProposalId 0) Created | ps.notUnlocked]
+    }
+
+mkStakeRef :: Int -> TxOutRef
+mkStakeRef = TxOutRef stakeTxRef . fromIntegral
+
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = Destroy
+
+--------------------------------------------------------------------------------
+
+destroy :: forall b. CombinableBuilder b => ParameterBundle -> b
+destroy ps =
+  let stakeInputDatum = mkStakeInputDatum ps.stakeInputParameters
+
+      sst = assetClassValue stakeAssetClass 1
+
+      stakeUTxOTemplate =
+        mconcat
+          [ script stakeScriptHash
+          , withDatum stakeInputDatum
+          , withValue $ normalizeValue $ sst <> minAda
+          ]
+
+      stakeInputBuilder =
+        foldMap
+          ( \i ->
+              input $
+                mconcat
+                  [ stakeUTxOTemplate
+                  , withRef $ mkStakeRef i
+                  , withRedeemer stakeRedeemer
+                  ]
+          )
+          [1 .. ps.stakeInputParameters.numInputs]
+
+      withSSTsBurnt =
+        mint $
+          normalizeValue $
+            assetClassValue stakeAssetClass $
+              negate $
+                fromIntegral ps.stakeBurningParameters.numBurnt
+
+      ---
+
+      leftOverStakes =
+        ps.stakeInputParameters.numInputs
+          - ps.stakeBurningParameters.numBurnt
+
+      stealSSTs =
+        case fromJust ps.stakeBurningParameters.leftOverStakeMode of
+          OutputAsIs ->
+            foldMap output $
+              replicate
+                leftOverStakes
+                stakeUTxOTemplate
+          CollectSSTInOneUTxO ->
+            output $
+              mconcat
+                [ pubKey signer2
+                , withValue $ stimesMonoid leftOverStakes sst
+                ]
+
+      stakeOutputBuilder =
+        assert (leftOverStakes >= 0) $
+          mconcat
+            [ withSSTsBurnt
+            , if leftOverStakes > 0
+                then stealSSTs
+                else mempty
+            ]
+
+      ---
+
+      sigBuilder = case ps.authorizedBy of
+        Owner -> signedWith owner
+        Delegatee -> signedWith delegatee
+        NotAuthorized -> mempty
+   in mconcat
+        [ stakeInputBuilder
+        , stakeOutputBuilder
+        , sigBuilder
+        ]
+
+--------------------------------------------------------------------------------
+
+mkTestTree ::
+  String ->
+  ParameterBundle ->
+  Validity ->
+  SpecificationTree
+mkTestTree name pb val = group name $ catMaybes [validator, policy]
+  where
+    spend = mkSpending destroy pb
+    mint = mkMinting destroy pb
+    validator =
+      Just $
+        testValidator
+          val.forStakeValidator
+          "stake validator"
+          stakeValidator
+          (mkStakeInputDatum pb.stakeInputParameters)
+          stakeRedeemer
+          (spend $ mkStakeRef 1)
+
+    policy = case pb.stakeBurningParameters.numBurnt of
+      0 -> Nothing
+      _ ->
+        Just $
+          testPolicy
+            (fromJust val.forStakePolicy)
+            "stake policy"
+            stakePolicy
+            ()
+            (mint stakeSymbol)
+
+--------------------------------------------------------------------------------
+
+mkTotallyValid :: Int -> ParameterBundle
+mkTotallyValid numStakes =
+  ParameterBundle
+    { stakeInputParameters =
+        StakeInputParameters
+          { numInputs = numStakes
+          , notUnlocked = False
+          }
+    , stakeBurningParameters =
+        StakeBurningParameters
+          { numBurnt = numStakes
+          , leftOverStakeMode = Nothing
+          }
+    , authorizedBy = Owner
+    }
+
+oneStake :: ParameterBundle
+oneStake = mkTotallyValid 1
+
+multipleStakes :: ParameterBundle
+multipleStakes = mkTotallyValid 10
+
+stealSST :: ParameterBundle
+stealSST =
+  multipleStakes
+    { stakeBurningParameters =
+        StakeBurningParameters
+          { numBurnt = 1
+          , leftOverStakeMode = Just CollectSSTInOneUTxO
+          }
+    }
+
+stealSST1 :: ParameterBundle
+stealSST1 =
+  multipleStakes
+    { stakeBurningParameters =
+        StakeBurningParameters
+          { numBurnt = 0
+          , leftOverStakeMode = Just CollectSSTInOneUTxO
+          }
+    }
+
+stealSST3 :: ParameterBundle
+stealSST3 =
+  multipleStakes
+    { stakeBurningParameters =
+        StakeBurningParameters
+          { numBurnt = 1
+          , leftOverStakeMode = Just OutputAsIs
+          }
+    }
+
+lockedStakes :: ParameterBundle
+lockedStakes =
+  multipleStakes
+    { stakeInputParameters =
+        multipleStakes.stakeInputParameters
+          { notUnlocked = True
+          }
+    }
+
+authorizedByDelegatee :: ParameterBundle
+authorizedByDelegatee =
+  multipleStakes
+    { authorizedBy = Delegatee
+    }
+
+notAuthorized :: ParameterBundle
+notAuthorized =
+  multipleStakes
+    { authorizedBy = NotAuthorized
+    }

agora-specs/Sample/Stake/SetDelegate.hs

@@ -20,39 +20,38 @@ module Sample.Stake.SetDelegate (
 ) where
 
 import Agora.Governor (Governor (gtClassRef))
-import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
   StakeDatum (..),
   StakeRedeemer (ClearDelegate, DelegateTo),
  )
-import Data.Tagged (untag)
 import Plutarch.Context (
   SpendingBuilder,
-  buildSpendingUnsafe,
+  buildSpending',
   input,
   output,
   script,
   signedWith,
   txId,
   withDatum,
-  withOutRef,
+  withRef,
   withSpendingOutRef,
   withValue,
  )
-import PlutusLedgerApi.V1 (
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
   PubKeyHash,
   ScriptContext,
   TxOutRef (TxOutRef),
  )
-import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Shared (
-  agoraScripts,
   governor,
   minAda,
   signer,
   signer2,
   stakeAssetClass,
-  stakeValidatorHash,
+  stakeScriptHash,
+  stakeValidator,
  )
 import Test.Specification (SpecificationTree, testValidator)
 import Test.Util (pubKeyHashes, sortValue)
@@ -73,7 +72,7 @@ data Parameters = Parameters
 
 -- | Select the correct stake redeemer based on the existence of the new delegate.
 mkStakeRedeemer :: Parameters -> StakeRedeemer
-mkStakeRedeemer (newDelegate -> d) = maybe ClearDelegate DelegateTo d
+mkStakeRedeemer params = maybe ClearDelegate (DelegateTo . PubKeyCredential) params.newDelegate
 
 -- | The owner of the input stake.
 stakeOwner :: PubKeyHash
@@ -84,14 +83,14 @@ mkStakeInputDatum :: Parameters -> StakeDatum
 mkStakeInputDatum ps =
   StakeDatum
     { stakedAmount = 5
-    , owner = stakeOwner
-    , delegatedTo = ps.existingDelegate
+    , owner = PubKeyCredential stakeOwner
+    , delegatedTo = PubKeyCredential <$> ps.existingDelegate
     , lockedBy = []
     }
 
 -- | Generate a 'ScriptContext' that tries to change the delegate of a stake.
 setDelegate :: Parameters -> ScriptContext
-setDelegate ps = buildSpendingUnsafe builder
+setDelegate ps = buildSpending' builder
   where
     stakeRef :: TxOutRef
     stakeRef = TxOutRef "0ffef57e30cc604342c738e31e0451593837b313e7bfb94b0922b142782f98e6" 1
@@ -105,22 +104,24 @@ setDelegate ps = buildSpendingUnsafe builder
               else stakeInput.stakedAmount
        in stakeInput
             { stakedAmount = stakedAmount
-            , delegatedTo = ps.newDelegate
+            , delegatedTo = PubKeyCredential <$> ps.newDelegate
             }
 
     signer =
       if ps.signedByOwner
-        then stakeInput.owner
+        then case stakeInput.owner of
+          PubKeyCredential c -> c
+          _ -> signer2
         else signer2
 
-    st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
+    st = assetClassValue stakeAssetClass 1 -- Stake ST
     stakeValue =
       sortValue $
         mconcat
           [ st
-          , Value.assetClassValue
-              (untag governor.gtClassRef)
-              (untag stakeInput.stakedAmount)
+          , assetClassValue
+              governor.gtClassRef
+              stakeInput.stakedAmount
           , minAda
           ]
 
@@ -131,14 +132,14 @@ setDelegate ps = buildSpendingUnsafe builder
         , signedWith signer
         , input $
             mconcat
-              [ script stakeValidatorHash
+              [ script stakeScriptHash
               , withValue stakeValue
               , withDatum stakeInput
-              , withOutRef stakeRef
+              , withRef stakeRef
               ]
         , output $
             mconcat
-              [ script stakeValidatorHash
+              [ script stakeScriptHash
               , withValue stakeValue
               , withDatum stakeOutput
               ]
@@ -155,7 +156,7 @@ mkTestCase name ps valid =
   testValidator
     valid
     name
-    agoraScripts.compiledStakeValidator
+    stakeValidator
     (mkStakeInputDatum ps)
     (mkStakeRedeemer ps)
     (setDelegate ps)

agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs

@@ -0,0 +1,74 @@
+module Sample.Stake.UnauthorizedMintingExploit (
+  Parameters (..),
+  exploit,
+  mkTestCase,
+) where
+
+import Plutarch.Context (
+  input,
+  mint,
+  normalizeValue,
+  output,
+  script,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V1.Value qualified as Value
+import Sample.Shared (
+  minAda,
+  stakeAssetClass,
+  stakePolicy,
+  stakeScriptHash,
+  stakeSymbol,
+ )
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (
+  CombinableBuilder,
+  mkMinting,
+  validatorHashes,
+ )
+
+newtype Parameters = Parameters
+  { inputSST :: Int
+  }
+
+exploit ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+exploit (Parameters inputSST) =
+  mconcat
+    [ input $
+        mconcat
+          [ script attacker
+          , withValue $
+              normalizeValue $
+                minAda <> fakeSSTValue inputSST
+          ]
+    , mint $ fakeSSTValue $ negate inputSST
+    , mint sst
+    , output $
+        mconcat
+          [ script stakeScriptHash
+          , withValue $
+              normalizeValue $
+                minAda <> sst
+          ]
+    ]
+  where
+    attacker = head validatorHashes
+
+    fakeSSTValue =
+      Value.singleton
+        stakeSymbol
+        (scriptHashToTokenName attacker)
+        . fromIntegral
+
+    sst = assetClassValue stakeAssetClass 1
+
+mkTestCase :: String -> Parameters -> SpecificationTree
+mkTestCase name ps =
+  testPolicy False name stakePolicy () $
+    mkMinting exploit ps stakeSymbol

agora-specs/Sample/Treasury.hs

@@ -18,8 +18,8 @@ module Sample.Treasury (
 ) where
 
 import Plutarch.Context (
-  MintingBuilder,
-  buildMintingUnsafe,
+  SpendingBuilder,
+  buildSpending',
   credential,
   input,
   mint,
@@ -27,23 +27,24 @@ import Plutarch.Context (
   script,
   signedWith,
   txId,
-  withMinting,
-  withTxId,
+  withRefTxId,
+  withSpendingOutRefId,
   withValue,
  )
-import PlutusLedgerApi.V1 (
-  Credential (PubKeyCredential),
-  PubKeyHash (PubKeyHash),
- )
 import PlutusLedgerApi.V1.Address (Address (..))
-import PlutusLedgerApi.V1.Contexts (
+import PlutusLedgerApi.V1.Value qualified as Value (singleton)
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
+  OutputDatum (NoOutputDatum),
+  PubKeyHash (PubKeyHash),
+  ScriptHash (ScriptHash),
+ )
+import PlutusLedgerApi.V2.Contexts (
   ScriptContext (..),
   TxInInfo (..),
   TxOut (..),
   TxOutRef (..),
  )
-import PlutusLedgerApi.V1.Scripts (ValidatorHash (ValidatorHash))
-import PlutusLedgerApi.V1.Value qualified as Value (singleton)
 import Sample.Shared (
   gatCs,
   gatTn,
@@ -54,13 +55,13 @@ import Sample.Shared (
   wrongEffHash,
  )
 
-baseCtxBuilder :: MintingBuilder
+baseCtxBuilder :: SpendingBuilder
 baseCtxBuilder =
   let treasury =
         mconcat
           [ credential trCredential
           , withValue minAda
-          , withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+          , withRefTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
           ]
    in mconcat
         [ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
@@ -68,7 +69,7 @@ baseCtxBuilder =
         , mint (Value.singleton gatCs gatTn (-1))
         , input treasury
         , output treasury
-        , withMinting gatCs
+        , withSpendingOutRefId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
         ]
 
 {- | A `ScriptContext` that should be compatible with treasury
@@ -76,7 +77,7 @@ baseCtxBuilder =
 -}
 validCtx :: ScriptContext
 validCtx =
-  let builder :: MintingBuilder
+  let builder :: SpendingBuilder
       builder =
         mconcat
           [ baseCtxBuilder
@@ -84,10 +85,10 @@ validCtx =
               mconcat
                 [ script mockTrEffectHash
                 , withValue (Value.singleton gatCs gatTn 1 <> minAda)
-                , withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+                , withRefTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
                 ]
           ]
-   in buildMintingUnsafe builder
+   in buildSpending' builder
 
 treasuryRef :: TxOutRef
 treasuryRef =
@@ -100,7 +101,7 @@ treasuryRef =
 -}
 walletIn :: TxInInfo
 walletIn =
-  let (ValidatorHash addressBs) = mockTrEffectHash
+  let (ScriptHash addressBs) = mockTrEffectHash
    in TxInInfo
         { txInInfoOutRef =
             TxOutRef
@@ -108,7 +109,8 @@ walletIn =
               0
         , txInInfoResolved =
             TxOut
-              { txOutDatumHash = Nothing
+              { txOutDatum = NoOutputDatum
+              , txOutReferenceScript = Nothing
               , txOutValue = Value.singleton gatCs gatTn 1
               , txOutAddress =
                   Address
@@ -119,7 +121,7 @@ walletIn =
 
 trCtxGATNameNotAddress :: ScriptContext
 trCtxGATNameNotAddress =
-  let builder :: MintingBuilder
+  let builder :: SpendingBuilder
       builder =
         mconcat
           [ baseCtxBuilder
@@ -127,7 +129,7 @@ trCtxGATNameNotAddress =
               mconcat
                 [ script wrongEffHash
                 , withValue (Value.singleton gatCs gatTn 1 <> minAda)
-                , withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+                , withRefTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
                 ]
           ]
-   in buildMintingUnsafe builder
+   in buildSpending' builder

agora-specs/Spec/AuthorityToken.hs

@@ -10,18 +10,18 @@ Tests for Authority token functions
 module Spec.AuthorityToken (specs) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Plutarch (ClosedTerm, POpaque, perror, popaque)
+import Data.Tagged (Tagged (Tagged))
 import Plutarch.Extra.Compile (mustCompile)
+import Plutarch.Script (Script)
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1 (
   Address (Address),
   Credential (PubKeyCredential, ScriptCredential),
   CurrencySymbol,
-  Script,
+  ScriptHash (ScriptHash),
   TxInInfo (TxInInfo),
   TxOut (TxOut),
   TxOutRef (TxOutRef),
-  ValidatorHash (ValidatorHash),
   Value,
  )
 import PlutusLedgerApi.V1.Value qualified as Value (
@@ -29,21 +29,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
   singleton,
  )
 import PlutusTx.AssocMap qualified as AssocMap (empty)
+import Sample.AuthorityToken.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
 import Test.Specification (
   SpecificationTree,
   group,
   scriptFails,
   scriptSucceeds,
  )
-import Prelude (
-  Maybe (Nothing),
-  PBool,
-  Semigroup ((<>)),
-  fmap,
-  pconstant,
-  pif,
-  ($),
- )
 
 currencySymbol :: CurrencySymbol
 currencySymbol = "deadbeef"
@@ -54,7 +46,7 @@ mkInputs = fmap (TxInInfo (TxOutRef "" 0))
 singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
 singleAuthorityTokenBurnedTest mint outs =
   let actual :: ClosedTerm PBool
-      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
+      actual = singleAuthorityTokenBurned (pconstant $ Tagged currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
       s :: ClosedTerm POpaque
       s =
         pif
@@ -76,7 +68,7 @@ specs =
                   <> Value.singleton "aa" "USDC" 100_000
               )
               [ TxOut
-                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 1)
                   Nothing
               ]
@@ -92,7 +84,7 @@ specs =
                   (Value.singleton "aaabcc" "hello-token" 1)
                   Nothing
               , TxOut
-                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 1)
                   Nothing
               , TxOut
@@ -101,6 +93,17 @@ specs =
                   Nothing
               ]
           )
+      , scriptSucceeds
+          "Correct even though scripts don't match"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
+                  Nothing
+              ]
+          )
       , scriptFails
           "Incorrect no burn"
           ( singleAuthorityTokenBurnedTest
@@ -115,17 +118,6 @@ specs =
               )
               []
           )
-      , scriptFails
-          "Incorrect script mismatch"
-          ( singleAuthorityTokenBurnedTest
-              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
-              )
-              [ TxOut
-                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
-                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
-                  Nothing
-              ]
-          )
       , scriptFails
           "Incorrect spent from PK"
           ( singleAuthorityTokenBurnedTest
@@ -144,10 +136,21 @@ specs =
                   <> Value.singleton "aa" "USDC" 100_000
               )
               [ TxOut
-                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 2)
                   Nothing
               ]
           )
       ]
+  , group "unauthorized minting exploit"
+      $ map
+        ( UnauthorizedMintingExploit.mkTestCase "(negative test)"
+            . uncurry UnauthorizedMintingExploit.Parameters
+        )
+      $ let l = [1 .. 10]
+         in [ (burnt, minted)
+            | burnt <- l
+            , minted <- l
+            , minted < burnt
+            ]
   ]

agora-specs/Spec/Effect/GovernorMutation.hs

@@ -1,20 +1,19 @@
 module Spec.Effect.GovernorMutation (specs) where
 
-import Agora.Effect.GovernorMutation (mutateGovernorValidator)
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
 import Agora.Proposal (ProposalId (..))
-import Agora.Scripts (AgoraScripts (..))
 import Data.Default.Class (Default (def))
-import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
+import PlutusLedgerApi.V2 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
 import Sample.Effect.GovernorMutation (
   effectRef,
+  effectValidator,
   govRef,
   invalidNewGovernorDatum,
   mkEffectDatum,
   mkEffectTxInfo,
   validNewGovernorDatum,
  )
-import Sample.Shared (agoraScripts, mkEffect)
+import Sample.Shared (governorValidator)
 import Test.Specification (
   SpecificationTree,
   effectFailsWith,
@@ -32,33 +31,42 @@ specs =
           "valid new governor datum"
           [ validatorSucceedsWith
               "governor validator should pass"
-              agoraScripts.compiledGovernorValidator
+              governorValidator
               ( GovernorDatum
                   def
-                  (ProposalId 0)
+                  nextProposalId
                   def
                   def
                   3
               )
               MutateGovernor
               ( ScriptContext
-                  (mkEffectTxInfo validNewGovernorDatum)
+                  (mkEffectTxInfo validNewGovernorDatum')
                   (Spending govRef)
               )
           , effectSucceedsWith
               "effect validator should pass"
-              (mkEffect $ mutateGovernorValidator agoraScripts)
-              (mkEffectDatum validNewGovernorDatum)
-              (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
+              effectValidator
+              ( mkEffectDatum
+                  ( GovernorDatum
+                      def
+                      nextProposalId
+                      def
+                      def
+                      3
+                  )
+                  validNewGovernorDatum
+              )
+              (ScriptContext (mkEffectTxInfo validNewGovernorDatum') (Spending effectRef))
           ]
       , group
           "invalid new governor datum"
           [ validatorFailsWith
               "governor validator should fail"
-              agoraScripts.compiledGovernorValidator
+              governorValidator
               ( GovernorDatum
                   def
-                  (ProposalId 0)
+                  nextProposalId
                   def
                   def
                   3
@@ -70,9 +78,26 @@ specs =
               )
           , effectFailsWith
               "effect validator should fail"
-              (mkEffect $ mutateGovernorValidator agoraScripts)
-              (mkEffectDatum validNewGovernorDatum)
+              effectValidator
+              ( mkEffectDatum
+                  ( GovernorDatum
+                      def
+                      nextProposalId
+                      def
+                      def
+                      3
+                  )
+                  validNewGovernorDatum
+              )
               (ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
           ]
       ]
   ]
+  where
+    validNewGovernorDatum' :: GovernorDatum
+    validNewGovernorDatum' = validNewGovernorDatum {nextProposalId}
+    -- \^ The datum value pinned by the effect, disregarding the proposal ID and
+    --   taking this field from the governor input instead
+
+    nextProposalId :: ProposalId
+    nextProposalId = ProposalId 0

agora-specs/Spec/Effect/TreasuryWithdrawal.hs

@@ -7,174 +7,44 @@ This module specs the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (specs) where
 
-import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
-  treasuryWithdrawalValidator,
- )
-import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Effect.TreasuryWithdrawal (
-  buildReceiversOutputFromDatum,
-  buildScriptContext,
-  currSymbol,
-  inputCollateral,
-  inputGAT,
-  inputTreasury,
-  inputUser,
-  outputTreasury,
-  outputUser,
-  treasuries,
-  users,
+  Parameters (..),
+  Validity (..),
+  mkTestTree,
+  totallyValidParameters,
  )
-import Sample.Shared (mkEffect)
 import Test.Specification (
   SpecificationTree,
-  effectFailsWith,
-  effectSucceedsWith,
-  group,
  )
-import Test.Util (sortValue)
 
 specs :: [SpecificationTree]
 specs =
-  [ group
-      "effect"
-      [ effectSucceedsWith
-          "Simple"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum1
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 10)
-              ]
-              $ outputTreasury 1 (asset1 7) :
-              buildReceiversOutputFromDatum datum1
-          )
-      , effectSucceedsWith
-          "Simple with multiple treasuries "
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum1
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 10)
-              , inputTreasury 2 (asset1 100)
-              , inputTreasury 3 (asset1 500)
-              ]
-              $ [ outputTreasury 1 (asset1 7)
-                , outputTreasury 2 (asset1 100)
-                , outputTreasury 3 (asset1 500)
-                ]
-                ++ buildReceiversOutputFromDatum datum1
-          )
-      , effectSucceedsWith
-          "Mixed Assets"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ buildReceiversOutputFromDatum datum2
-          )
-      , effectFailsWith
-          "Pay to uknown 3rd party"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputUser 100 (asset1 2)
-                , outputTreasury 1 (asset1 11)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ buildReceiversOutputFromDatum datum2
-          )
-      , effectFailsWith
-          "Missing receiver"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ drop 1 (buildReceiversOutputFromDatum datum2)
-          )
-      , effectFailsWith
-          "Unauthorized treasury"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 999 (asset1 20)
-              ]
-              $ outputTreasury 999 (asset1 17) :
-              buildReceiversOutputFromDatum datum3
-          )
-      , effectFailsWith
-          "Prevent transactions besides the withdrawal"
-          (mkEffect $ treasuryWithdrawalValidator currSymbol)
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 999 (asset1 20)
-              , inputUser 99 (asset2 100)
-              ]
-              $ [ outputTreasury 1 (asset1 17)
-                , outputUser 100 (asset2 100)
-                ]
-                ++ buildReceiversOutputFromDatum datum3
-          )
-      ]
+  [ mkTestTree
+      "totally valid"
+      totallyValidParameters
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = True
+        , forTreasury = True
+        }
+  , mkTestTree
+      "bad received value"
+      totallyValidParameters
+        { badReceivedValue = True
+        }
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = False
+        , forTreasury = True
+        }
+  , mkTestTree
+      "bad receiver order"
+      totallyValidParameters
+        { badReceiverOrder = True
+        }
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = False
+        , forTreasury = True
+        }
   ]
-  where
-    asset1 =
-      Value.singleton
-        "0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
-        "OrangeBottle"
-    asset2 =
-      Value.singleton
-        "7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
-        "19721121"
-    datum1 =
-      TreasuryWithdrawalDatum
-        [ (head users, asset1 1)
-        , (users !! 1, asset1 1)
-        , (users !! 2, asset1 1)
-        ]
-        [ treasuries !! 1
-        , treasuries !! 2
-        , treasuries !! 3
-        ]
-    datum2 =
-      TreasuryWithdrawalDatum
-        [ (head users, sortValue $ asset2 5 <> asset1 4)
-        , (users !! 1, sortValue $ asset2 1 <> asset1 2)
-        , (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]

agora-specs/Spec/Proposal.hs

@@ -10,8 +10,10 @@ module Spec.Proposal (specs) where
 import Sample.Proposal.Advance qualified as Advance
 import Sample.Proposal.Cosign qualified as Cosign
 import Sample.Proposal.Create qualified as Create
-import Sample.Proposal.UnlockStake qualified as UnlockStake
+import Sample.Proposal.PrivilegeEscalate qualified as PrivilegeEscalate
+import Sample.Proposal.Unlock qualified as Unlock
 import Sample.Proposal.Vote qualified as Vote
+
 import Test.Specification (
   SpecificationTree,
   group,
@@ -52,8 +54,8 @@ specs =
               "invalid stake locks"
               Create.addInvalidLocksParameters
               True
-              False
               True
+              False
           , Create.mkTestTree
               "has reached maximum proposals limit"
               Create.exceedMaximumProposalsParameters
@@ -83,59 +85,127 @@ specs =
                       True
                 )
                 Create.invalidProposalStatusParameters
+          , Create.mkTestTree
+              "fake SST"
+              Create.fakeSSTParameters
+              True
+              False
+              False
+          , Create.mkTestTree
+              "wrong governor redeemer"
+              Create.wrongGovernorRedeemer
+              False
+              False
+              True
+          , Create.mkTestTree
+              "wrong governor redeemer"
+              Create.wrongGovernorRedeemer1
+              False
+              False
+              True
           ]
       ]
   , group
       "validator"
       [ group
           "cosignature"
-          $ let cosignerCases = [1, 5, 10]
-
-                mkLegalGroup nCosigners =
-                  Cosign.mkTestTree
-                    (unwords ["with", show nCosigners, "cosigners"])
-                    (Cosign.validCosignNParameters nCosigners)
-                    True
-                legalGroup =
-                  group "legal" $
-                    map mkLegalGroup cosignerCases
-
-                mkIllegalStatusNotDraftGroup nCosigners =
-                  group (unwords ["with", show nCosigners, "cosigners"]) $
-                    map
-                      ( \ps ->
-                          Cosign.mkTestTree
-                            ("status: " <> show ps.proposalStatus)
-                            ps
-                            False
-                      )
-                      (Cosign.statusNotDraftCosignNParameters nCosigners)
-                illegalStatusNotDraftGroup =
-                  group "proposal status not Draft" $
-                    map mkIllegalStatusNotDraftGroup cosignerCases
-
-                illegalGroup =
-                  group
-                    "illegal"
-                    [ Cosign.mkTestTree
-                        "duplicate cosigners"
-                        Cosign.duplicateCosignersParameters
-                        False
-                    , Cosign.mkTestTree
-                        "altered output stake"
-                        Cosign.invalidStakeOutputParameters
-                        False
-                    , illegalStatusNotDraftGroup
-                    ]
-             in [legalGroup, illegalGroup]
+          [ Cosign.mkTestTree
+              "legal"
+              Cosign.totallyValid
+              (Cosign.Validity True True)
+          , group
+              "illegal"
+              [ Cosign.mkTestTree
+                  "insufficient staked amount"
+                  Cosign.insufficientStakedAmount
+                  (Cosign.Validity False True)
+              , Cosign.mkTestTree
+                  "proposal locks not updated"
+                  Cosign.locksNotUpdated
+                  (Cosign.Validity True False)
+              , Cosign.mkTestTree
+                  "duplicate cosigners"
+                  Cosign.duplicateCosigners
+                  (Cosign.Validity False True)
+              , Cosign.mkTestTree
+                  "cosigners not updated"
+                  Cosign.cosignersNotUpdated
+                  (Cosign.Validity False True)
+              , group "cosign after draft" $
+                  map
+                    ( \b ->
+                        Cosign.mkTestTree
+                          "(negative test)"
+                          b
+                          (Cosign.Validity False True)
+                    )
+                    Cosign.cosignAfterDraft
+              ]
+          ]
       , group
           "voting"
           [ group
               "legal"
-              [ Vote.mkTestTree "ordinary" Vote.validVoteParameters True
-              , Vote.mkTestTree "delegate" Vote.validVoteAsDelegateParameters True
+              [ group "different number of stakes" $
+                  map
+                    ( \s ->
+                        group
+                          (unwords [show s, "stakes"])
+                          [ Vote.mkTestTree
+                              "by owner"
+                              (Vote.mkValidOwnerVoteBundle s)
+                              (Vote.Validity True True)
+                          , Vote.mkTestTree
+                              "by delegatee"
+                              (Vote.mkValidDelegateeVoteBundle s)
+                              (Vote.Validity True True)
+                          ]
+                    )
+                    [1, 3, 5, 7, 9]
+              , Vote.mkTestTree
+                  "transparent non-GT tokens"
+                  Vote.transparentAssets
+                  (Vote.Validity True True)
+              , Vote.mkTestTree
+                  "Delegatee vote with own and delegated stakes in one tx"
+                  Vote.delegateeVoteWithOwnAndDelegatedStakeBundle
+                  (Vote.Validity True True)
+              ]
+          , group
+              "illegal"
+              [ Vote.mkTestTree
+                  "vote for nonexistent outcome"
+                  Vote.voteForNonexistentOutcome
+                  (Vote.Validity False True)
+              , Vote.mkTestTree
+                  "unauthorized tx"
+                  Vote.transactionNotAuthorized
+                  (Vote.Validity True False)
+              , Vote.mkTestTree
+                  "no proposal"
+                  Vote.noProposal
+                  (Vote.Validity False False)
+              , Vote.mkTestTree
+                  "more than one proposals"
+                  Vote.voteForNonexistentOutcome
+                  (Vote.Validity False True)
+              , Vote.mkTestTree
+                  "locks not added"
+                  Vote.invalidLocks
+                  (Vote.Validity True False)
+              , Vote.mkTestTree
+                  "attempt to burn stakes"
+                  Vote.destroyStakes
+                  (Vote.Validity True False)
+              , Vote.mkTestTree
+                  "insufficient staked amount"
+                  Vote.insufficientAmount
+                  (Vote.Validity False True)
+              , Vote.mkTestTree
+                  "insufficient staked amount"
+                  Vote.insufficientAmount1
+                  (Vote.Validity False True)
               ]
-              -- TODO: add negative test cases
           ]
       , group
           "advancing"
@@ -184,6 +254,11 @@ specs =
                                     mkName
                                     (Advance.mkValidToFailedStateBundles cs es)
                                     allValid
+                                , Advance.mkTestTree'
+                                    "to finished state with inline datum"
+                                    mkName
+                                    (Advance.mkValidToFinishedInlineGATDatumBundles cs es)
+                                    allValid
                                 ]
                       , group
                           "illegal"
@@ -234,16 +309,6 @@ specs =
                                 , forGovernorValidator = Just True
                                 , forAuthorityTokenPolicy = Just True
                                 }
-                          , Advance.mkTestTree'
-                              "altered output stake datum"
-                              (\b -> unwords ["from", show b.proposalParameters.fromStatus])
-                              (Advance.mkInvalidOutputStakeBundles cs es)
-                              Advance.Validity
-                                { forProposalValidator = False
-                                , forStakeValidator = False
-                                , forGovernorValidator = Just True
-                                , forAuthorityTokenPolicy = Just True
-                                }
                           , Advance.mkTestTree
                               "forget to mint GATs"
                               (Advance.mkNoGATMintedBundle cs es)
@@ -269,7 +334,7 @@ specs =
                                 { forProposalValidator = True
                                 , forStakeValidator = True
                                 , forGovernorValidator = Just False
-                                , forAuthorityTokenPolicy = Just False
+                                , forAuthorityTokenPolicy = Just True
                                 }
                           , Advance.mkTestTree
                               "wrong GAT datum"
@@ -289,106 +354,113 @@ specs =
                                 , forGovernorValidator = Just False
                                 , forAuthorityTokenPolicy = Just True
                                 }
+                          , Advance.mkTestTree'
+                              "fastforward to finished"
+                              (\b -> unwords ["from", show b.proposalParameters.fromStatus])
+                              (Advance.mkFastforwardToFinishBundles cs es)
+                              Advance.Validity
+                                { forProposalValidator = False
+                                , forStakeValidator = True
+                                , forGovernorValidator = Just False
+                                , forAuthorityTokenPolicy = Just True
+                                }
+                          , Advance.mkTestTree
+                              "wrong governor redeemer"
+                              (Advance.mkBadGovernorRedeemerBundle cs es)
+                              Advance.Validity
+                                { forProposalValidator = True
+                                , forStakeValidator = True
+                                , forGovernorValidator = Just False
+                                , forAuthorityTokenPolicy = Just False
+                                }
                           ]
                       ]
       , group "unlocking" $
-          let proposalCountCases = [1, 5, 10, 42]
+          let stakeCountCases = [1, 3, 5, 7, 9, 11]
 
-              mkSubgroupName nProposals = unwords ["with", show nProposals, "proposals"]
+              mkSubgroupName nStakes = unwords ["with", show nStakes, "stakes"]
 
-              mkLegalGroup nProposals =
+              mkLegalGroup nStakes =
                 group
-                  (mkSubgroupName nProposals)
-                  [ UnlockStake.mkTestTree
+                  (mkSubgroupName nStakes)
+                  [ Unlock.mkTestTree
                       "voter: retract votes while voting"
-                      (UnlockStake.mkVoterRetractVotesWhileVotingParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
+                      (Unlock.mkValidVoterRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "voter: retract votes while voting by delegatee"
+                      (Unlock.mkValidDelegateeRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
                       "voter/creator: retract votes while voting"
-                      (UnlockStake.mkVoterCreatorRetractVotesWhileVotingParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
-                      "creator: remove creator locks when finished"
-                      (UnlockStake.mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
-                      "voter/creator: remove all locks when finished"
-                      (UnlockStake.mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals)
-                      True
-                  , group "voter: unlock after voting" $
-                      map
-                        ( \ps ->
-                            let name = show ps.proposalStatus
-                             in UnlockStake.mkTestTree name ps True
-                        )
-                        (UnlockStake.mkVoterUnlockStakeAfterVotingParameters nProposals)
-                  , UnlockStake.mkTestTree
-                      "voter/creator: remove vote locks when locked"
-                      (UnlockStake.mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals)
-                      True
+                      (Unlock.mkValidVoterCreatorRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "creator: remove creator lock after voting"
+                      (Unlock.mkValidCreatorRemoveLock nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "Voter: remove lock after voting"
+                      (Unlock.mkValidVoterRemoveLockAfterVoting nStakes)
+                      (Unlock.Validity True True)
                   ]
 
-              mkIllegalGroup nProposals =
+              mkIllegalGroup nStakes =
                 group
-                  (mkSubgroupName nProposals)
+                  (mkSubgroupName nStakes)
                   [ group "retract votes while not voting" $
                       map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "role:"
-                                    , show ps.stakeRole
-                                    , ","
-                                    , "status:"
-                                    , show ps.proposalStatus
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
+                        ( \c ->
+                            Unlock.mkTestTree
+                              "(negative test)"
+                              c
+                              (Unlock.Validity False True)
                         )
-                        (UnlockStake.mkRetractVotesWhileNotVoting nProposals)
-                  , group "unlock an irrelevant stake" $
-                      map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "status:"
-                                    , show ps.proposalStatus
-                                    , "retract votes:"
-                                    , show ps.retractVotes
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
-                        )
-                        (UnlockStake.mkUnockIrrelevantStakeParameters nProposals)
+                        (Unlock.mkRetractVotesWhileNotVoting nStakes)
                   , group "remove creator too early" $
                       map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    ["status:", show ps.proposalStatus]
-                             in UnlockStake.mkTestTree name ps False
+                        ( \c ->
+                            Unlock.mkTestTree
+                              "(negative test)"
+                              c
+                              (Unlock.Validity True False)
                         )
-                        (UnlockStake.mkRemoveCreatorLockBeforeFinishedParameters nProposals)
-                  , UnlockStake.mkTestTree
+                        (Unlock.mkRemoveCreatorLockBeforeFinished nStakes)
+                  , Unlock.mkTestTree
+                      "unlock an irrelevant stake"
+                      (Unlock.mkUnockIrrelevantStakes nStakes)
+                      (Unlock.Validity False False)
+                  , Unlock.mkTestTree
                       "creator: retract votes"
-                      (UnlockStake.mkRetractVotesWithCreatorStakeParamaters nProposals)
-                      False
-                  , group "alter output stake datum" $
-                      map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "role:"
-                                    , show ps.stakeRole
-                                    , ","
-                                    , "status:"
-                                    , show ps.proposalStatus
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
-                        )
-                        (UnlockStake.mkAlterStakeParameters nProposals)
+                      (Unlock.mkCreatorRetractVotes nStakes)
+                      (Unlock.Validity False True)
+                  , Unlock.mkTestTree
+                      "change output stake value"
+                      (Unlock.mkChangeOutputStakeValue nStakes)
+                      (Unlock.Validity True False)
+                  , Unlock.mkTestTree
+                      "use fake stake"
+                      (Unlock.mkUseFakeStakes nStakes)
+                      (Unlock.Validity False False)
+                  , Unlock.mkTestTree
+                      "retract votes in cooldown"
+                      (Unlock.mkDisrespectCooldown nStakes)
+                      (Unlock.Validity True False)
                   ]
 
-              legalGroup = group "legal" $ map mkLegalGroup proposalCountCases
-              illegalGroup = group "illegal" $ map mkIllegalGroup proposalCountCases
+              legalGroup = group "legal" $ map mkLegalGroup stakeCountCases
+              illegalGroup = group "illegal" $ map mkIllegalGroup stakeCountCases
            in [legalGroup, illegalGroup]
       ]
+  , group
+      "privilege escalate"
+      [ PrivilegeEscalate.mkTestTree
+          "vote"
+          PrivilegeEscalate.Voting
+          (PrivilegeEscalate.Validity False False)
+      , PrivilegeEscalate.mkTestTree
+          "retract votes"
+          PrivilegeEscalate.RetractingVotes
+          (PrivilegeEscalate.Validity False False)
+      ]
   ]

agora-specs/Spec/Stake.hs

@@ -9,14 +9,12 @@ Tests for Stake policy and validator
 -}
 module Spec.Stake (specs) where
 
-import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
   StakeDatum (StakeDatum),
   StakeRedeemer (DepositWithdraw),
  )
-import Data.Bool (Bool (..))
-import Data.Maybe (Maybe (..))
-import Sample.Shared (agoraScripts)
+import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
+import Sample.Shared (stakeValidator)
 import Sample.Stake (
   DepositWithdrawExample (
     DepositWithdrawExample,
@@ -26,61 +24,133 @@ import Sample.Stake (
   signer,
  )
 import Sample.Stake qualified as Stake (
-  stakeCreation,
-  stakeCreationUnsigned,
-  stakeCreationWrongDatum,
   stakeDepositWithdraw,
  )
+import Sample.Stake.Create qualified as Create
+import Sample.Stake.Destroy qualified as Destroy
 import Sample.Stake.SetDelegate qualified as SetDelegate
+import Sample.Stake.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
 import Test.Specification (
   SpecificationTree,
   group,
-  policyFailsWith,
-  policySucceedsWith,
   validatorFailsWith,
   validatorSucceedsWith,
  )
-import Prelude (Num (negate), ($))
 
 -- | The SpecificationTree exported by this module.
 specs :: [SpecificationTree]
 specs =
   [ group
       "policy"
-      [ policySucceedsWith
-          "stakeCreation"
-          agoraScripts.compiledStakePolicy
-          ()
-          Stake.stakeCreation
-      , policyFailsWith
-          "stakeCreationWrongDatum"
-          agoraScripts.compiledStakePolicy
-          ()
-          Stake.stakeCreationWrongDatum
-      , policyFailsWith
-          "stakeCreationUnsigned"
-          agoraScripts.compiledStakePolicy
-          ()
-          Stake.stakeCreationUnsigned
+      [ group
+          "create"
+          [ group
+              "valid"
+              [ Create.mkTestCase
+                  "stake owner: pub key"
+                  Create.ownerIsPubKeyTotallyValid
+                  True
+              , Create.mkTestCase
+                  "stake owner: script"
+                  Create.ownerIsScriptTotallyValid
+                  True
+              ]
+          , group
+              "invalid"
+              [ Create.mkTestCase
+                  "mint more than one sst in one tx"
+                  Create.createMoreThanOneStake
+                  False
+              , Create.mkTestCase
+                  "spend stake while minting SST"
+                  Create.spendStake
+                  False
+              , Create.mkTestCase
+                  "wrong staked amount"
+                  Create.unexpectedStakedAmount
+                  False
+              , Create.mkTestCase
+                  "no stake datum"
+                  Create.noStakeDatum
+                  False
+              , Create.mkTestCase
+                  "bad stake datum"
+                  Create.malformedStakeDatum
+                  False
+              , Create.mkTestCase
+                  "not authorized by owner"
+                  Create.notAuthorizedByOwner
+                  False
+              , Create.mkTestCase
+                  "delegatee not empty"
+                  Create.setDelegatee
+                  False
+              , Create.mkTestCase
+                  "have locks"
+                  Create.alreadyHasLocks
+                  False
+              ]
+          ]
       ]
   , group
       "validator"
-      [ validatorSucceedsWith
+      [ group
+          "destroy"
+          [ group
+              "legal"
+              [ Destroy.mkTestTree
+                  "One stake"
+                  Destroy.oneStake
+                  (Destroy.Validity (Just True) True)
+              , Destroy.mkTestTree
+                  "Multiple stake"
+                  Destroy.multipleStakes
+                  (Destroy.Validity (Just True) True)
+              ]
+          , group
+              "illegal"
+              [ Destroy.mkTestTree
+                  "Destroy only one stake to steal SST"
+                  Destroy.stealSST
+                  (Destroy.Validity (Just False) False)
+              , Destroy.mkTestTree
+                  "Destroy nothing to steal SST"
+                  Destroy.stealSST1
+                  (Destroy.Validity Nothing False)
+              , Destroy.mkTestTree
+                  "Steal SST"
+                  Destroy.stealSST3
+                  (Destroy.Validity (Just False) False)
+              , Destroy.mkTestTree
+                  "Destroy locked stakes"
+                  Destroy.lockedStakes
+                  (Destroy.Validity (Just True) False)
+              , Destroy.mkTestTree
+                  "not authorized by owner"
+                  Destroy.notAuthorized
+                  (Destroy.Validity (Just True) False)
+              , Destroy.mkTestTree
+                  "not authorized by owner"
+                  Destroy.authorizedByDelegatee
+                  (Destroy.Validity (Just True) False)
+              ]
+          ]
+      , validatorSucceedsWith
           "stakeDepositWithdraw deposit"
-          agoraScripts.compiledStakeValidator
-          (StakeDatum 100_000 signer Nothing [])
+          stakeValidator
+          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
           (DepositWithdraw 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
       , validatorSucceedsWith
           "stakeDepositWithdraw withdraw"
-          agoraScripts.compiledStakeValidator
-          (StakeDatum 100_000 signer Nothing [])
+          stakeValidator
+          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
           (DepositWithdraw $ negate 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
       , validatorFailsWith
           "stakeDepositWithdraw negative GT"
-          agoraScripts.compiledStakeValidator
-          (StakeDatum 100_000 signer Nothing [])
+          stakeValidator
+          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
           (DepositWithdraw 1_000_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
       , group
@@ -110,5 +180,13 @@ specs =
               SetDelegate.invalidOutputStakeDatumParameters
               False
           ]
+      , group
+          "unauthorized SST minting exploit"
+          $ map
+            ( UnauthorizedMintingExploit.mkTestCase
+                "(negative test)"
+                . UnauthorizedMintingExploit.Parameters
+            )
+            [1 .. 20]
       ]
   ]

agora-specs/Spec/Treasury.hs

@@ -21,28 +21,22 @@ Tests need to fail when:
 -}
 module Spec.Treasury (specs) where
 
-import Agora.Treasury (
-  TreasuryRedeemer (SpendTreasuryGAT),
-  treasuryValidator,
- )
-import Agora.Utils (CompiledValidator (CompiledValidator))
-import Plutarch.Api.V1 (mkValidator)
-import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey))
-import PlutusLedgerApi.V1.Contexts (
-  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
-  ScriptPurpose (Certifying, Rewarding, Spending),
-  TxInfo (txInfoInputs, txInfoMint),
- )
+import Plutarch.Script (Script)
 import PlutusLedgerApi.V1.Credential (
   StakingCredential (StakingHash),
  )
 import PlutusLedgerApi.V1.Value qualified as Value (singleton)
-import Sample.Shared (deterministicTracingConfing, trCredential)
+import PlutusLedgerApi.V2 (DCert (DCertDelegRegKey))
+import PlutusLedgerApi.V2.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Certifying, Minting, Rewarding),
+  TxInfo (txInfoInputs, txInfoMint),
+ )
+import Sample.Shared (trCredential, trValidator)
 import Sample.Treasury (
   gatCs,
   gatTn,
   trCtxGATNameNotAddress,
-  treasuryRef,
   validCtx,
   walletIn,
  )
@@ -53,11 +47,8 @@ import Test.Specification (
   validatorSucceedsWith,
  )
 
-compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
-compiledTreasuryValidator =
-  CompiledValidator $
-    mkValidator deterministicTracingConfing $
-      treasuryValidator gatCs
+compiledTreasuryValidator :: Script
+compiledTreasuryValidator = trValidator
 
 specs :: [SpecificationTree]
 specs =
@@ -69,26 +60,32 @@ specs =
               "Allows for effect changes"
               compiledTreasuryValidator
               ()
-              SpendTreasuryGAT
+              ()
               validCtx
+          , validatorSucceedsWith
+              "Fails when GAT token name is not script address"
+              compiledTreasuryValidator
+              ()
+              ()
+              trCtxGATNameNotAddress
           ]
       , group
           "Negative"
           [ group
-              "Fails with ScriptPurpose not Minting"
+              "Fails with ScriptPurpose not Spending"
               [ validatorFailsWith
-                  "Spending"
+                  "Minting"
                   compiledTreasuryValidator
                   ()
-                  SpendTreasuryGAT
+                  ()
                   validCtx
-                    { scriptContextPurpose = Spending treasuryRef
+                    { scriptContextPurpose = Minting ""
                     }
               , validatorFailsWith
                   "Rewarding"
                   compiledTreasuryValidator
                   ()
-                  SpendTreasuryGAT
+                  ()
                   validCtx
                     { scriptContextPurpose =
                         Rewarding $
@@ -98,7 +95,7 @@ specs =
                   "Certifying"
                   compiledTreasuryValidator
                   ()
-                  SpendTreasuryGAT
+                  ()
                   validCtx
                     { scriptContextPurpose =
                         Certifying $
@@ -110,7 +107,7 @@ specs =
               "Fails when multiple GATs burned"
               compiledTreasuryValidator
               ()
-              SpendTreasuryGAT
+              ()
               validCtx
                 { scriptContextTxInfo =
                     validCtx.scriptContextTxInfo
@@ -121,17 +118,11 @@ specs =
                             (-2)
                       }
                 }
-          , validatorFailsWith
-              "Fails when GAT token name is not script address"
-              compiledTreasuryValidator
-              ()
-              SpendTreasuryGAT
-              trCtxGATNameNotAddress
           , validatorFailsWith
               "Fails with wallet as input"
               compiledTreasuryValidator
               ()
-              SpendTreasuryGAT
+              ()
               ( let txInfo = validCtx.scriptContextTxInfo
                     inputs = txInfo.txInfoInputs
                     newInputs =

agora-specs/Spec/Utils.hs

@@ -7,7 +7,8 @@ Tests for utility functions in 'Agora.Utils'.
 -}
 module Spec.Utils (tests) where
 
-import Test.Tasty (TestTree)
+import Property.Utils qualified as Props
+import Test.Tasty (TestTree, testGroup)
 
 tests :: [TestTree]
-tests = []
+tests = [testGroup "properties" Props.props]

agora-test/Golden.hs

@@ -0,0 +1,52 @@
+module Golden (testGolden) where
+
+import Agora.Bootstrap qualified as Bootstrap
+import Agora.Linker (linker)
+import Data.Text qualified as Text
+import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
+import ScriptExport.File qualified as ScriptExport
+import ScriptExport.Options qualified as ScriptExport
+import ScriptExport.Types qualified as ScriptExport
+import System.Directory (createDirectoryIfMissing)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Golden (goldenVsFile)
+import Test.Tasty.Providers (TestName)
+
+builders :: ScriptExport.Builders
+builders =
+  mconcat
+    [ ScriptExport.insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts (Config NoTracing)) linker
+    , ScriptExport.insertScriptExportWithLinker "agoraDebug" (Bootstrap.agoraScripts (Config DoTracing)) linker
+    ]
+
+testGolden :: TestTree
+testGolden =
+  testGroup
+    "Golden tests for script export"
+    [ goldenTest "agora" "./agora-test/goldens/"
+    , goldenTest "agoraDebug" "./agora-test/goldens/"
+    ]
+
+goldenTest :: TestName -> FilePath -> TestTree
+goldenTest builder outputPath =
+  let mkFilename suffix = outputPath <> builder <> suffix <> ".json"
+      goldenFilename = mkFilename "-golden"
+      sampleFilename = mkFilename ""
+   in goldenVsFile
+        builder
+        goldenFilename
+        sampleFilename
+        $ callExportScript builder outputPath
+
+-- Call the script server and generate an unapplied script set.
+callExportScript :: String -> FilePath -> IO ()
+callExportScript builder outputPath = do
+  _ <- createDirectoryIfMissing False outputPath
+  ScriptExport.runFile
+    builders
+    ( ScriptExport.FileOptions
+        { out = outputPath
+        , param = ""
+        , builder = Text.pack builder
+        }
+    )

agora-test/Spec.hs

@@ -1,8 +1,5 @@
-import Prelude
-
---------------------------------------------------------------------------------
-
 import GHC.IO.Encoding (setLocaleEncoding, utf8)
+import Golden qualified
 import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
@@ -26,7 +23,8 @@ main = do
   defaultMain $
     testGroup
       "test suite"
-      [ testGroup
+      [ Golden.testGolden
+      , testGroup
           "Effects"
           [ toTestTree $ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs
           , toTestTree $ group "Governor Mutation Effect" GovernorMutation.specs

agora-testlib/Test/Specification.hs

@@ -49,21 +49,25 @@ module Test.Specification (
   toTestTree,
 ) where
 
-import Agora.Utils (CompiledEffect (..), CompiledMintingPolicy (..), CompiledValidator (..))
 import Control.Composition ((.**), (.***))
 import Data.Coerce (coerce)
+import Data.Text qualified as Text
 import Plutarch.Evaluate (evalScript)
-import PlutusLedgerApi.V1 (
+import Plutarch.Script (Script (Script))
+import PlutusCore.Data qualified as PLC
+import PlutusCore.MkPlc qualified as PLC
+import PlutusLedgerApi.V2 (
   Datum (..),
   Redeemer (Redeemer),
-  Script,
   ScriptContext,
   ToData (toBuiltinData),
+  toData,
  )
-import PlutusLedgerApi.V1.Scripts (Context (..), applyMintingPolicyScript, applyValidator)
+import PlutusPrelude (over)
 import PlutusTx.IsData qualified as PlutusTx (ToData)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (assertFailure, testCase)
+import UntypedPlutusCore qualified as UPLC
 
 {- | Expectations upon execution of script
  @Success@ indicates a successful execution.
@@ -129,8 +133,12 @@ toTestTree (Terminal (Specification name expectation script)) =
       Failure -> onFailure
       FailureWith s -> onFailureWith s
   where
+    beautifyTraces =
+      Text.unpack
+        . Text.intercalate "\n"
+        . map ("  " <>)
     (res, _budget, traces) = evalScript script
-    ts = " Traces: " <> show traces
+    ts = " Traces:\n" <> beautifyTraces traces
     onSuccess = case res of
       Left e ->
         assertFailure $
@@ -159,9 +167,6 @@ scriptSucceeds name script = Terminal $ Specification name Success script
 scriptFails :: String -> Script -> SpecificationTree
 scriptFails name script = Terminal $ Specification name Failure script
 
-mkContext :: ScriptContext -> Context
-mkContext = Context . toBuiltinData
-
 mkRedeemer ::
   forall redeemer.
   (PlutusTx.ToData redeemer) =>
@@ -178,37 +183,39 @@ mkDatum = Datum . toBuiltinData
 
 applyMintingPolicy' ::
   (PlutusTx.ToData redeemer) =>
-  CompiledMintingPolicy redeemer ->
+  Script ->
   redeemer ->
   ScriptContext ->
   Script
 applyMintingPolicy' policy redeemer scriptContext =
-  applyMintingPolicyScript
-    (mkContext scriptContext)
-    (getCompiledMintingPolicy policy)
-    (mkRedeemer redeemer)
+  applyArguments
+    policy
+    [ toData $ mkRedeemer redeemer
+    , toData scriptContext
+    ]
 
 applyValidator' ::
   ( PlutusTx.ToData datum
   , PlutusTx.ToData redeemer
   ) =>
-  CompiledValidator datum redeemer ->
+  Script ->
   datum ->
   redeemer ->
   ScriptContext ->
   Script
 applyValidator' validator datum redeemer scriptContext =
-  applyValidator
-    (mkContext scriptContext)
-    (getCompiledValidator validator)
-    (mkDatum datum)
-    (mkRedeemer redeemer)
+  applyArguments
+    validator
+    [ toData $ mkDatum datum
+    , toData $ mkRedeemer redeemer
+    , toData scriptContext
+    ]
 
 -- | Check that a policy script succeeds, given a name and arguments.
 policySucceedsWith ::
   (PlutusTx.ToData redeemer) =>
   String ->
-  CompiledMintingPolicy redeemer ->
+  Script ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -219,7 +226,7 @@ policySucceedsWith tag =
 policyFailsWith ::
   (PlutusTx.ToData redeemer) =>
   String ->
-  CompiledMintingPolicy redeemer ->
+  Script ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -232,7 +239,7 @@ validatorSucceedsWith ::
   , PlutusTx.ToData redeemer
   ) =>
   String ->
-  CompiledValidator datum redeemer ->
+  Script ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -246,7 +253,7 @@ validatorFailsWith ::
   , PlutusTx.ToData redeemer
   ) =>
   String ->
-  CompiledValidator datum redeemer ->
+  Script ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -259,7 +266,7 @@ effectSucceedsWith ::
   ( PlutusTx.ToData datum
   ) =>
   String ->
-  CompiledEffect datum ->
+  Script ->
   datum ->
   ScriptContext ->
   SpecificationTree
@@ -270,7 +277,7 @@ effectFailsWith ::
   ( PlutusTx.ToData datum
   ) =>
   String ->
-  CompiledEffect datum ->
+  Script ->
   datum ->
   ScriptContext ->
   SpecificationTree
@@ -283,7 +290,7 @@ testValidator ::
   -- | Is this test case expected to succeed?
   Bool ->
   String ->
-  CompiledValidator datum redeemer ->
+  Script ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -300,7 +307,7 @@ testPolicy ::
   -- | Is this test case expected to succeed?
   Bool ->
   String ->
-  CompiledMintingPolicy redeemer ->
+  Script ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -308,3 +315,11 @@ testPolicy isValid =
   if isValid
     then policySucceedsWith
     else policyFailsWith
+
+--------------------------------------------------------------------------------
+
+applyArguments :: Script -> [PLC.Data] -> Script
+applyArguments (Script p) args =
+  let termArgs = fmap (PLC.mkConstant ()) args
+      applied t = PLC.mkIterApp () t termArgs
+   in Script $ over UPLC.progTerm applied p

agora-testlib/Test/Util.hs

@@ -15,6 +15,7 @@ module Test.Util (
   sortValue,
   blake2b_224,
   pubKeyHashes,
+  scriptHashes,
   userCredentials,
   scriptCredentials,
   validatorHashes,
@@ -22,6 +23,7 @@ module Test.Util (
   mkSpending,
   mkMinting,
   CombinableBuilder,
+  subtractValue,
 ) where
 
 --------------------------------------------------------------------------------
@@ -36,31 +38,32 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
 import Data.List (sortOn)
 import Plutarch.Context (
   Builder,
-  buildMintingUnsafe,
-  buildSpendingUnsafe,
+  buildMinting',
+  buildSpending',
   withMinting,
   withSpendingOutRef,
  )
 import Plutarch.Crypto (pblake2b_256)
-import PlutusLedgerApi.V1 (
+import PlutusLedgerApi.V1.Interval qualified as PlutusTx
+import PlutusLedgerApi.V1.Value (Value (..))
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
   Credential (
     PubKeyCredential,
     ScriptCredential
   ),
   CurrencySymbol,
+  Datum (Datum),
+  DatumHash (DatumHash),
   PubKeyHash (..),
   ScriptContext,
+  ScriptHash (ScriptHash),
   TxOutRef,
-  ValidatorHash (ValidatorHash),
  )
-import PlutusLedgerApi.V1.Interval qualified as PlutusTx
-import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash))
-import PlutusLedgerApi.V1.Value (Value (..))
 import PlutusTx.AssocMap qualified as AssocMap
 import PlutusTx.Builtins qualified as PlutusTx
 import PlutusTx.IsData qualified as PlutusTx
 import PlutusTx.Ord qualified as PlutusTx
-import Prelude
 
 --------------------------------------------------------------------------------
 
@@ -155,13 +158,17 @@ userCredentials :: [Credential]
 userCredentials = PubKeyCredential <$> pubKeyHashes
 
 -- | An infinite list of *valid* validator hashes.
-validatorHashes :: [ValidatorHash]
-validatorHashes = ValidatorHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
+validatorHashes :: [ScriptHash]
+validatorHashes = ScriptHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
 
 -- | An infinite list of *valid* script credentials.
 scriptCredentials :: [Credential]
 scriptCredentials = ScriptCredential <$> validatorHashes
 
+-- | An infinite list of *valid* script hashes.
+scriptHashes :: [ScriptHash]
+scriptHashes = ScriptHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
+
 --------------------------------------------------------------------------------
 
 -- | Turn the given list in to groups which have the given length.
@@ -190,7 +197,7 @@ mkSpending ::
   TxOutRef ->
   ScriptContext
 mkSpending mkBuilder ps oref =
-  buildSpendingUnsafe $
+  buildSpending' $
     mkBuilder ps <> withSpendingOutRef oref
 
 {- | Given the builder generator and the parameters, create a 'ScriptContext'
@@ -203,7 +210,12 @@ mkMinting ::
   CurrencySymbol ->
   ScriptContext
 mkMinting mkBuilder ps cs =
-  buildMintingUnsafe $
+  buildMinting' $
     mkBuilder ps <> withMinting cs
 
 type CombinableBuilder b = (Monoid b, Builder b)
+
+--------------------------------------------------------------------------------
+
+subtractValue :: Value -> Value -> Value
+subtractValue = Value.unionWith (-)

agora.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               agora
-version:            0.2.0
+version:            1.0.0
 extra-source-files: CHANGELOG.md
 author:             Emily Martins <emi@haskell.fyi>
 license:            Apache-2.0
@@ -18,10 +18,6 @@ common lang
     -Wmissing-deriving-strategies -Wno-name-shadowing -Wunused-foralls
     -fprint-explicit-foralls -fprint-explicit-kinds -Wunused-do-bind
 
-  mixins:
-    base hiding (Prelude),
-    pprelude (PPrelude as Prelude)
-
   default-extensions:
     NoStarIsType
     BangPatterns
@@ -81,6 +77,7 @@ common lang
     TypeSynonymInstances
     UndecidableInstances
     ViewPatterns
+    NoFieldSelectors
     OverloadedRecordDot
 
   default-language:   Haskell2010
@@ -89,7 +86,7 @@ common deps
   build-depends:
     , aeson
     , ansi-terminal
-    , base                    >=4.14 && <5
+    , base                   >=4.14 && <5
     , base-compat
     , base16
     , bytestring
@@ -99,15 +96,18 @@ common deps
     , containers
     , data-default
     , data-default-class
+    , filepath
     , generics-sop
     , liqwid-plutarch-extra
+    , liqwid-script-export
+    , optics
     , plutarch
-    , plutarch-numeric
-    , plutarch-safe-money
-    , plutarch-script-export
+    , plutarch-extra
     , plutus-core
     , plutus-ledger-api
     , plutus-tx
+    , ply-core
+    , ply-plutarch
     , pprelude
     , prettyprinter
     , recursion-schemes
@@ -116,13 +116,17 @@ common deps
     , template-haskell
     , text
 
+common plutarch-prelude
   mixins:
+    base hiding (Prelude),
+    pprelude (PPrelude as Prelude)
 
 common test-deps
   build-depends:
     , agora
     , cryptonite
     , data-default-class
+    , directory
     , memory
     , mtl
     , plutarch-context-builder
@@ -130,6 +134,7 @@ common test-deps
     , QuickCheck
     , quickcheck-instances
     , tasty
+    , tasty-golden
     , tasty-hedgehog
     , tasty-hunit
     , tasty-quickcheck
@@ -139,25 +144,30 @@ common test-deps
 common exe-opts
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0
 
+common test-opts
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2
+
 library
-  import:          lang, deps
+  import:          lang, deps, plutarch-prelude
   exposed-modules:
     Agora.Aeson.Orphans
     Agora.AuthorityToken
     Agora.Bootstrap
+    Agora.Credential
     Agora.Effect
     Agora.Effect.GovernorMutation
     Agora.Effect.NoOp
     Agora.Effect.TreasuryWithdrawal
     Agora.Governor
     Agora.Governor.Scripts
+    Agora.Linker
     Agora.Plutarch.Orphans
     Agora.Proposal
     Agora.Proposal.Scripts
     Agora.Proposal.Time
     Agora.SafeMoney
-    Agora.Scripts
     Agora.Stake
+    Agora.Stake.Redeemers
     Agora.Stake.Scripts
     Agora.Treasury
     Agora.Utils
@@ -174,7 +184,7 @@ library pprelude
     , plutarch
 
 library agora-testlib
-  import:          lang, deps, test-deps
+  import:          lang, deps, plutarch-prelude, test-deps
   exposed-modules:
     Test.Specification
     Test.Util
@@ -182,10 +192,12 @@ library agora-testlib
   hs-source-dirs:  agora-testlib
 
 library agora-specs
-  import:          lang, deps, test-deps
+  import:          lang, deps, plutarch-prelude, test-deps
   exposed-modules:
     Property.Generator
     Property.Governor
+    Property.Utils
+    Sample.AuthorityToken.UnauthorizedMintingExploit
     Sample.Effect.GovernorMutation
     Sample.Effect.TreasuryWithdrawal
     Sample.Governor.Initialize
@@ -193,12 +205,16 @@ library agora-specs
     Sample.Proposal.Advance
     Sample.Proposal.Cosign
     Sample.Proposal.Create
+    Sample.Proposal.PrivilegeEscalate
     Sample.Proposal.Shared
-    Sample.Proposal.UnlockStake
+    Sample.Proposal.Unlock
     Sample.Proposal.Vote
     Sample.Shared
     Sample.Stake
+    Sample.Stake.Create
+    Sample.Stake.Destroy
     Sample.Stake.SetDelegate
+    Sample.Stake.UnauthorizedMintingExploit
     Sample.Treasury
     Spec.AuthorityToken
     Spec.Effect.GovernorMutation
@@ -210,19 +226,23 @@ library agora-specs
     Spec.Utils
 
   hs-source-dirs:  agora-specs
-  build-depends:   agora-testlib
+  build-depends:
+    , agora-testlib
+    , ordered-containers
 
 test-suite agora-test
-  import:         lang, deps, test-deps
+  import:         lang, deps, plutarch-prelude, test-deps, test-opts
   type:           exitcode-stdio-1.0
   main-is:        Spec.hs
   hs-source-dirs: agora-test
+  other-modules:  Golden
   build-depends:
+    , agora
     , agora-specs
     , agora-testlib
 
 benchmark agora-bench
-  import:         lang, deps
+  import:         lang, deps, plutarch-prelude
   hs-source-dirs: agora-bench
   main-is:        Main.hs
   other-modules:
@@ -244,11 +264,14 @@ executable agora-scripts
   hs-source-dirs: agora-scripts
   other-modules:
   build-depends:
+    , aeson-pretty
     , agora
     , gitrev
 
+  mixins:         base
+
 executable agora-purescript-bridge
-  import:         lang, deps, exe-opts
+  import:         lang, deps, plutarch-prelude, exe-opts
   main-is:        Bridge.hs
   hs-source-dirs: agora-purescript-bridge
   other-modules:

agora/Agora/Aeson/Orphans.hs

@@ -5,7 +5,7 @@ module Agora.Aeson.Orphans (AsBase16Bytes (..)) where
 --------------------------------------------------------------------------------
 
 import Data.Coerce (Coercible, coerce)
-import Prelude
+import Plutarch.Orphans ()
 
 --------------------------------------------------------------------------------
 
@@ -20,7 +20,6 @@ import Data.Text.Encoding qualified as T
 
 import PlutusLedgerApi.V1 qualified as Plutus
 import PlutusLedgerApi.V1.Bytes qualified as Plutus
-import PlutusLedgerApi.V1.Scripts qualified as Plutus
 import PlutusLedgerApi.V1.Value qualified as Plutus
 
 --------------------------------------------------------------------------------
@@ -38,19 +37,6 @@ deriving via
   instance
     Aeson.FromJSON Plutus.AssetClass
 
-deriving via
-  AsBase16Bytes Plutus.TxId
-  instance
-    Aeson.FromJSON Plutus.TxId
-
-deriving via
-  AsBase16Bytes Plutus.TxId
-  instance
-    Aeson.ToJSON Plutus.TxId
-
-deriving anyclass instance Aeson.FromJSON Plutus.TxOutRef
-deriving anyclass instance Aeson.ToJSON Plutus.TxOutRef
-
 instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) where
   toJSON =
     Aeson.String
@@ -80,86 +66,3 @@ instance (Codec.Serialise a) => Aeson.FromJSON (AsBase16Codec a) where
         . Codec.deserialiseOrFail
         . Lazy.fromStrict
         . T.encodeUtf8
-
---------------------------------------------------------------------------------
-
-deriving via
-  (AsBase16Bytes Plutus.CurrencySymbol)
-  instance
-    (Aeson.ToJSON Plutus.CurrencySymbol)
-deriving via
-  (AsBase16Bytes Plutus.CurrencySymbol)
-  instance
-    (Aeson.FromJSON Plutus.CurrencySymbol)
-
-deriving via
-  (AsBase16Bytes Plutus.TokenName)
-  instance
-    (Aeson.ToJSON Plutus.TokenName)
-deriving via
-  (AsBase16Bytes Plutus.TokenName)
-  instance
-    (Aeson.FromJSON Plutus.TokenName)
-
-deriving via
-  (AsBase16Bytes Plutus.ValidatorHash)
-  instance
-    (Aeson.ToJSON Plutus.ValidatorHash)
-deriving via
-  (AsBase16Bytes Plutus.ValidatorHash)
-  instance
-    (Aeson.FromJSON Plutus.ValidatorHash)
-
-deriving via
-  (AsBase16Bytes Plutus.ScriptHash)
-  instance
-    (Aeson.ToJSON Plutus.ScriptHash)
-deriving via
-  (AsBase16Bytes Plutus.ScriptHash)
-  instance
-    (Aeson.FromJSON Plutus.ScriptHash)
-
-deriving via
-  (AsBase16Bytes Plutus.BuiltinByteString)
-  instance
-    (Aeson.ToJSON Plutus.BuiltinByteString)
-deriving via
-  (AsBase16Bytes Plutus.BuiltinByteString)
-  instance
-    (Aeson.FromJSON Plutus.BuiltinByteString)
-
-deriving via
-  (AsBase16Codec Plutus.Validator)
-  instance
-    (Aeson.ToJSON Plutus.Validator)
-deriving via
-  (AsBase16Codec Plutus.Validator)
-  instance
-    (Aeson.FromJSON Plutus.Validator)
-
-deriving via
-  (AsBase16Codec Plutus.MintingPolicy)
-  instance
-    (Aeson.ToJSON Plutus.MintingPolicy)
-deriving via
-  (AsBase16Codec Plutus.MintingPolicy)
-  instance
-    (Aeson.FromJSON Plutus.MintingPolicy)
-
-deriving via
-  (AsBase16Codec Plutus.Script)
-  instance
-    (Aeson.ToJSON Plutus.Script)
-deriving via
-  (AsBase16Codec Plutus.Script)
-  instance
-    (Aeson.FromJSON Plutus.Script)
-
-deriving via
-  Integer
-  instance
-    (Aeson.ToJSON Plutus.POSIXTime)
-deriving via
-  Integer
-  instance
-    (Aeson.FromJSON Plutus.POSIXTime)

agora/Agora/AuthorityToken.hs

@@ -9,56 +9,52 @@ module Agora.AuthorityToken (
   authorityTokenPolicy,
   authorityTokensValidIn,
   singleAuthorityTokenBurned,
-  AuthorityToken (..),
 ) where
 
+import Agora.Governor (PGovernorRedeemer (PMintGATs), presolveGovernorRedeemer)
+import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
+import Agora.Utils (ptag, ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
 import Plutarch.Api.V1 (
-  AmountGuarantees,
-  KeyGuarantees,
-  PAddress (..),
   PCredential (..),
   PCurrencySymbol (..),
-  PMintingPolicy,
-  PScriptContext (..),
-  PScriptPurpose (..),
-  PTxInInfo (PTxInInfo),
-  PTxInfo (..),
-  PTxOut (..),
  )
-import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf)
 import Plutarch.Api.V1.AssocMap (PMap (PMap))
-import Plutarch.Api.V1.ScriptContext (pisTokenSpent)
-import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
-import "plutarch" Plutarch.Api.V1.Value (PValue (PValue))
-import Plutarch.Builtin (pforgetData)
-import Plutarch.Extra.List (plookup)
-import Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
-import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
-
---------------------------------------------------------------------------------
-
-{- | An AuthorityToken represents a proof that a particular token
-     spent in the same transaction the AuthorityToken was minted.
-     In effect, this means that the validator that locked such a token
-     must have approved the transaction in which an AuthorityToken is minted.
-     Said validator should be made aware of an AuthorityToken token's existence
-     in order to prevent incorrect minting.
-
-     @since 0.1.0
--}
-newtype AuthorityToken = AuthorityToken
-  { authority :: AssetClass
-  -- ^ Token that must move in order for minting this to be valid.
-  }
-  deriving stock
-    ( -- | @since 0.1.0
-      Generic
-    )
+import Plutarch.Api.V1.Value (PValue (PValue))
+import Plutarch.Api.V2 (
+  AmountGuarantees,
+  KeyGuarantees,
+  PAddress (PAddress),
+  PMintingPolicy,
+  PScriptPurpose (PMinting),
+  PTxInInfo (PTxInInfo),
+  PTxOut (PTxOut),
+ )
+import Plutarch.Extra.AssetClass (PAssetClassData)
+import Plutarch.Extra.Bool (passert)
+import Plutarch.Extra.Maybe (passertPJust, pfromJust)
+import Plutarch.Extra.Sum (PSum (PSum))
+import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Traversable (pfoldMap)
+import Plutarch.Extra.Value (psymbolValueOf')
+import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
+  pguardC,
+  pletC,
+  pletFieldsC,
+  pmatchC,
+ )
 
 --------------------------------------------------------------------------------
 
 {- | Check that all GATs are valid in a particular TxOut.
-     How this is checked: an AuthorityToken should never leave
+
+     WARNING: As of version 1.0.0, this has been weakened in order to be
+     compatible with RATs. The token name is no loger checked, meaning that a
+     GAT can escape from its effect script, if the effect script is vulnerable.
+     In order to prevent this, all effect scripts should be implemented carefully,
+     and ideally use the trusted effect base. See also 'Agora.Effect'.
+
+     (before 1.0.0) How this is checked: an AuthorityToken should never leave
      the Effect it was initially sent to, so we simply check that
      the script address the token resides in matches the TokenName.
      Since the TokenName was tagged upon mint with the Effect script
@@ -66,9 +62,9 @@ newtype AuthorityToken = AuthorityToken
      In other words, check that all assets of a particular currency symbol
      are tagged with a TokenName that matches where they live.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
-authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
+authorityTokensValidIn :: forall (s :: S). Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PTxOut :--> PBool)
 authorityTokensValidIn = phoistAcyclic $
   plam $ \authorityTokenSym txOut'' -> unTermCont $ do
     PTxOut txOut' <- pmatchC txOut''
@@ -77,25 +73,21 @@ authorityTokensValidIn = phoistAcyclic $
     PValue value' <- pmatchC txOut.value
     PMap value <- pmatchC value'
     pure $
-      pmatch (plookup # pdata authorityTokenSym # value) $ \case
-        PJust (pfromData -> tokenMap') ->
+      pmatch (plookupAssoc # pfstBuiltin # psndBuiltin # pdata (puntag authorityTokenSym) # value) $ \case
+        PJust (pfromData -> _tokenMap') ->
           pmatch (pfield @"credential" # address) $ \case
             PPubKeyCredential _ ->
               -- GATs should only be sent to Effect validators
               ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
-            PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> unTermCont $ do
-              PMap tokenMap <- pmatchC tokenMap'
-              pure $
-                ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
-                  pall
-                    # plam
-                      ( \pair ->
-                          pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
-                      )
-                    # tokenMap
+            PScriptCredential _ ->
+              -- NOTE: We no longer can perform a check on `TokenName` content here.
+              -- Instead, the auth check system uses `TokenName`s, but it cannot
+              -- check for GATs incorrectly escaping scripts. The effect scripts
+              -- need to be written very carefully in order to disallow this.
+              pcon PTrue
         PNothing ->
           -- No GATs exist at this output!
-          pconstant True
+          pcon PTrue
 
 {- | Assert that a single authority token has been burned.
 
@@ -103,60 +95,97 @@ authorityTokensValidIn = phoistAcyclic $
 -}
 singleAuthorityTokenBurned ::
   forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
-  Term s PCurrencySymbol ->
+  Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
   Term s (PBuiltinList PTxInInfo) ->
   Term s (PValue keys amounts) ->
   Term s PBool
 singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
   let gatAmountMinted :: Term _ PInteger
-      gatAmountMinted = psymbolValueOf # gatCs # mint
+      gatAmountMinted = ptaggedSymbolValueOf # gatCs # mint
+
+  let inputsWithGAT =
+        pfoldMap
+          # plam
+            ( flip pmatch $ \case
+                PTxInInfo txInInfo -> unTermCont $ do
+                  resolved <- pletC $ pfield @"resolved" # txInInfo
+
+                  pguardC "While counting GATs at inputs: all GATs must be valid"
+                    $ authorityTokensValidIn
+                      # gatCs
+                      #$ pfromData
+                    $ resolved
+
+                  pure . pcon . PSum $
+                    ptaggedSymbolValueOf
+                      # gatCs
+                      #$ pfield @"value"
+                      #$ resolved
+            )
+          # inputs
 
   pure $
     foldr1
       (#&&)
-      [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
-      , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
-          pall
-            # plam
-              ( \txInInfo' -> unTermCont $ do
-                  PTxInInfo txInInfo <- pmatchC txInInfo'
-                  let txOut' = pfield @"resolved" # txInInfo
-                  pure $ authorityTokensValidIn # gatCs # pfromData txOut'
-              )
-            # inputs
+      [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $
+          gatAmountMinted #== -1
+      , ptraceIfFalse "Only one GAT must exist at the inputs" $
+          inputsWithGAT #== 1
       ]
 
 {- | Policy given 'AuthorityToken' params.
 
+     == Authority Token
+
+     An AuthorityToken represents a proof that a particular token
+     spent in the same transaction the AuthorityToken was minted.
+     In effect, this means that the validator that locked such a token
+     must have approved the transaction in which an AuthorityToken is minted.
+     Said validator should be made aware of an AuthorityToken token's existence
+     in order to prevent incorrect minting.
+
      @since 0.1.0
 -}
-authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
-authorityTokenPolicy params =
-  plam $ \_redeemer ctx' ->
-    pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
-      ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-      PTxInfo txInfo' <- pmatchC $ pfromData ctx.txInfo
-      txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo'
-      let inputs = txInfo.inputs
-          mintedValue = pfromData txInfo.mint
-          AssetClass (govCs, govTn) = params.authority
-          govAc = passetClass # pconstant govCs # pconstant govTn
-          govTokenSpent = pisTokenSpent # govAc # inputs
+authorityTokenPolicy :: ClosedTerm (PAsData (PTagged GovernorSTTag PAssetClassData) :--> PMintingPolicy)
+authorityTokenPolicy =
+  plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
+    ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
+    txInfoF <-
+      pletFieldsC
+        @'[ "inputs"
+          , "mint"
+          , "outputs"
+          , "redeemers"
+          ]
+        ctxF.txInfo
 
-      PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
+    PMinting ownSymbol' <- pmatchC $ pfromData ctxF.purpose
 
-      let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
-          mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
-      pure $
+    let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
+
+    PPair mintedATs burntATs <-
+      pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfoF.mint
+
+    pure $
+      popaque $
         pif
           (0 #< mintedATs)
           ( unTermCont $ do
-              pguardC "Parent token did not move in minting GATs" govTokenSpent
+              pguardC "No GAT burnt" $ 0 #== burntATs
+              let governorRedeemer =
+                    passertPJust
+                      # "GST should move"
+                      #$ presolveGovernorRedeemer
+                      # (ptoScottEncodingT # pfromData gstAssetClass)
+                      # pfromData txInfoF.inputs
+                      # txInfoF.redeemers
+              pguardC "Governor redeemr correct" $
+                pcon PMintGATs #== governorRedeemer
               pguardC "All outputs only emit valid GATs" $
                 pall
                   # plam
-                    (authorityTokensValidIn # ownSymbol #)
-                  # txInfo.outputs
-              pure $ popaque $ pconstant ()
+                    (authorityTokensValidIn # ptag ownSymbol #)
+                  # txInfoF.outputs
+              pure $ pconstant ()
           )
-          (popaque $ pconstant ())
+          (passert "No GAT minted" (0 #== mintedATs) (pconstant ()))

agora/Agora/Bootstrap.hs

@@ -4,64 +4,91 @@
 
      Initialize a governance system
 -}
-module Agora.Bootstrap (agoraScripts) where
+module Agora.Bootstrap (agoraScripts, agoraScripts', alwaysSucceedsPolicyRoledScript) where
 
-import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy)
-import Agora.Governor (Governor (..))
+import Agora.AuthorityToken (authorityTokenPolicy)
+import Agora.Effect.GovernorMutation (mutateGovernorValidator)
+import Agora.Effect.NoOp (noOpValidator)
+import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
 import Agora.Governor.Scripts (governorPolicy, governorValidator)
 import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
-import Agora.Scripts (AgoraScripts (AgoraScripts))
-import Agora.Scripts qualified as Scripts
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 import Agora.Treasury (treasuryValidator)
-import Agora.Utils (
-  CompiledMintingPolicy (..),
-  CompiledValidator (..),
- )
+import Data.Map (fromList)
+import Data.Text (Text, unpack)
 import Plutarch (Config)
-import Plutarch.Api.V1 (
-  mintingPolicySymbol,
-  mkMintingPolicy,
-  mkValidator,
- )
-import PlutusLedgerApi.V1.Value (AssetClass (..))
+import Plutarch.Api.V2 (PMintingPolicy)
+import Plutarch.Extra.Compile (mustCompile)
+import Ply (ScriptRole (MintingPolicyRole), TypedScriptEnvelope)
+import Ply.Plutarch.TypedWriter (TypedWriter, mkEnvelope)
+import ScriptExport.ScriptInfo (RawScriptExport (..), RoledScript (..))
 
-{- | Parameterize and precompiled core scripts, given the
-     'Agora.Governor.Governor' parameters and plutarch configurations.
+{- | Parameterize core scripts, given the 'Agora.Governor.Governor'
+     parameters and plutarch configurations.
 
-     @since 0.2.0
+     @since 1.0.0
 -}
-agoraScripts :: Config -> Governor -> AgoraScripts
-agoraScripts conf gov = scripts
+agoraScripts :: Config -> RawScriptExport
+agoraScripts conf =
+  RawScriptExport $
+    fromList
+      [ envelope "agora:governorPolicy" governorPolicy
+      , envelope "agora:governorValidator" governorValidator
+      , envelope "agora:stakePolicy" stakePolicy
+      , envelope "agora:stakeValidator" stakeValidator
+      , envelope "agora:proposalPolicy" proposalPolicy
+      , envelope "agora:proposalValidator" proposalValidator
+      , envelope "agora:treasuryValidator" treasuryValidator
+      , envelope "agora:authorityTokenPolicy" authorityTokenPolicy
+      , envelope "agora:noOpValidator" noOpValidator
+      , envelope "agora:treasuryWithdrawalValidator" treasuryWithdrawalValidator
+      , envelope "agora:mutateGovernorValidator" mutateGovernorValidator
+      ]
   where
-    mkMintingPolicy' = mkMintingPolicy conf
-    mkValidator' = mkValidator conf
+    envelope ::
+      forall (pt :: S -> Type).
+      TypedWriter pt =>
+      Text ->
+      ClosedTerm pt ->
+      (Text, TypedScriptEnvelope)
+    envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t)
 
-    compiledGovernorPolicy = mkMintingPolicy' $ governorPolicy gov.gstOutRef
-    compiledGovernorValidator = mkValidator' $ governorValidator scripts
-    governorSymbol = mintingPolicySymbol compiledGovernorPolicy
-    governorAssetClass = AssetClass (governorSymbol, "")
+agoraScripts' :: Config -> Either Text [TypedScriptEnvelope]
+agoraScripts' conf =
+  sequenceA
+    [ envelope "Governor Policy" governorPolicy
+    , envelope "Governor Validator" governorValidator
+    , envelope "Stake Policy" stakePolicy
+    , envelope "Stake Validator" stakeValidator
+    , envelope "Proposal Policy" proposalPolicy
+    , envelope "Proposal Validator" proposalValidator
+    , envelope "Treasury Validator" treasuryValidator
+    , envelope "Authority Token Policy" authorityTokenPolicy
+    , envelope "NoOp Validator" noOpValidator
+    , envelope "Treasury Withdrawal Validator" treasuryWithdrawalValidator
+    , envelope "Mutate Governor Validator" mutateGovernorValidator
+    , envelope "Always Succeeds Policy" ((plam $ \_ _ -> popaque $ pcon PUnit) :: Term s PMintingPolicy)
+    ]
+  where
+    envelope ::
+      forall (pt :: S -> Type).
+      TypedWriter pt =>
+      Text ->
+      ClosedTerm pt ->
+      Either Text TypedScriptEnvelope
+    envelope = mkEnvelope conf
 
-    authority = AuthorityToken governorAssetClass
-    compiledAuthorityPolicy = mkMintingPolicy' $ authorityTokenPolicy authority
-    authorityTokenSymbol = mintingPolicySymbol compiledAuthorityPolicy
+{- | A minting policy that always succeeds.
 
-    compiledProposalPolicy = mkMintingPolicy' $ proposalPolicy governorAssetClass
-    compiledProposalValidator = mkValidator' $ proposalValidator scripts gov.maximumCosigners
+  NOTE(Emily, Jan 3rd 2023): Adding this in here because it's useful for testnet GT.
+    In reality, it shouldn't be used by anyone on mainnet, but removing it is not
+    productive for off-chain testing.
 
-    compiledStakePolicy = mkMintingPolicy' $ stakePolicy gov.gtClassRef
-    compiledStakeValidator = mkValidator' $ stakeValidator scripts gov.gtClassRef
-
-    compiledTreasuryValidator = mkValidator' $ treasuryValidator authorityTokenSymbol
-
-    scripts =
-      AgoraScripts
-        { Scripts.compiledGovernorPolicy = CompiledMintingPolicy compiledGovernorPolicy
-        , Scripts.compiledGovernorValidator = CompiledValidator compiledGovernorValidator
-        , Scripts.compiledStakePolicy = CompiledMintingPolicy compiledStakePolicy
-        , Scripts.compiledStakeValidator = CompiledValidator compiledStakeValidator
-        , Scripts.compiledProposalPolicy = CompiledMintingPolicy compiledProposalPolicy
-        , Scripts.compiledProposalValidator = CompiledValidator compiledProposalValidator
-        , Scripts.compiledTreasuryValidator = CompiledValidator compiledTreasuryValidator
-        , Scripts.compiledAuthorityTokenPolicy = CompiledMintingPolicy compiledAuthorityPolicy
-        }
+  @since 1.0.0
+-}
+alwaysSucceedsPolicyRoledScript :: RoledScript
+alwaysSucceedsPolicyRoledScript =
+  RoledScript
+    { script = mustCompile @PMintingPolicy $ plam $ \_ _ -> popaque $ pcon PUnit
+    , role = MintingPolicyRole
+    }

agora/Agora/Credential.hs

@@ -0,0 +1,77 @@
+{- |
+Module     : Agora.Stake.Scripts
+Maintainer : emi@haskell.fyi
+Description: Functions for dealing with generalized credentials.
+
+Functions for dealing with generalized credentials.
+-}
+module Agora.Credential (
+  pauthorizedBy,
+  authorizationContext,
+) where
+
+import GHC.Records (HasField)
+import Plutarch.Api.V1 (PCredential (PPubKeyCredential, PScriptCredential), PPubKeyHash)
+import Plutarch.Api.V2 (PTxInInfo)
+import Plutarch.Extra.ScriptContext (ptxSignedBy)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pmatchC)
+
+{- | Context required in order to check 'AuthorizationCredential'.
+
+     Construct using 'authorizationContext'.
+
+     @since 1.0.0
+-}
+data PAuthorizationContext (s :: S) = PAuthorizationContext
+  { signatories :: Term s (PBuiltinList (PAsData PPubKeyHash))
+  , inputs :: Term s (PBuiltinList PTxInInfo)
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    , -- | @since 1.0.0
+      PEq
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PAuthorizationContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Build up 'PAuthorizationContext' from fields.
+
+     @since 1.0.0
+-}
+authorizationContext ::
+  forall (s :: S) (r :: Type).
+  ( HasField "inputs" r (Term s (PBuiltinList PTxInInfo))
+  , HasField "signatories" r (Term s (PBuiltinList (PAsData PPubKeyHash)))
+  ) =>
+  r ->
+  Term s PAuthorizationContext
+authorizationContext f =
+  pcon (PAuthorizationContext f.signatories f.inputs)
+
+{- | Check for authorization by credential.
+
+     @since 1.0.0
+-}
+pauthorizedBy :: forall (s :: S). Term s (PAuthorizationContext :--> PCredential :--> PBool)
+pauthorizedBy = phoistAcyclic $
+  plam $ \ctx credential -> unTermCont $ do
+    ctxF <- pmatchC ctx
+    pure $
+      pmatch credential $ \case
+        PPubKeyCredential ((pfield @"_0" #) -> pk) ->
+          ptxSignedBy # ctxF.signatories # pk
+        PScriptCredential ((pfield @"_0" #) -> _) ->
+          pany
+            # plam
+              ( \input ->
+                  (pfield @"credential" #$ pfield @"address" #$ pfield @"resolved" # input)
+                    #== credential
+              )
+            # ctxF.inputs

agora/Agora/Effect.hs

@@ -8,17 +8,18 @@ Helpers for constructing effects.
 module Agora.Effect (makeEffect) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Agora.SafeMoney (AuthorityTokenTag)
 import Plutarch.Api.V1 (
   PCurrencySymbol,
+ )
+import Plutarch.Api.V2 (
   PScriptPurpose (PSpending),
   PTxInfo,
   PTxOutRef,
   PValidator,
-  PValue,
  )
-import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
-import Plutarch.TryFrom ()
-import PlutusLedgerApi.V1.Value (CurrencySymbol)
+import Plutarch.Extra.Tagged (PTagged)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
 
 {- | Helper "template" for creating effect validator.
 
@@ -26,36 +27,46 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
      an effect is implemented. In such situations, it's okay to not use this
      helper.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 makeEffect ::
-  forall (datum :: PType).
+  forall (datum :: PType) (s :: S).
   (PTryFrom PData datum, PIsData datum) =>
-  CurrencySymbol ->
-  (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
-  ClosedTerm PValidator
-makeEffect gatCs' f =
+  ( Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
+    Term s datum ->
+    Term s PTxOutRef ->
+    Term s (PAsData PTxInfo) ->
+    Term s POpaque
+  ) ->
+  Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol)) ->
+  Term s PValidator
+makeEffect f atSymbol' =
   plam $ \datum _redeemer ctx' -> unTermCont $ do
+    atSymbol <- pletC $ pfromData atSymbol'
     ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
 
-    -- convert input datum, PData, into desierable type
+    -- Convert input datum, PData, into desierable type
     -- the way this conversion is performed should be defined
     -- by PTryFrom for each datum in effect script.
-    (datum', _) <- ptryFromC datum
+    datum' <- fst <$> ptryFromC datum
 
-    -- ensure purpose is Spending.
+    -- Ensure purpose is Spending. Why? The only way that this
+    -- effect script can actually pass any validation onto other
+    -- scripts is by preventing the spend of the GAT.
+    --
+    -- - In the case of GATs which don't get burned, that will
+    --   allow reuse of the GAT.
+    --
+    -- - In the case of GATs which get _referenced_, this script
+    --   won't be run at all, in which case. The auth check needs
+    --   to be especially written with that in mind.
     PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
     txOutRef' <- pletC (pfield @"_0" # txOutRef)
 
-    -- fetch minted values to ensure single GAT is burned
     txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
-    let mint :: Term _ (PValue _ _)
-        mint = txInfo.mint
 
-    -- fetch script context
-    gatCs <- pletC $ pconstant gatCs'
-
-    pguardC "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo.inputs mint
+    pguardC "A single authority token has been burned" $
+      singleAuthorityTokenBurned atSymbol txInfo.inputs txInfo.mint
 
     -- run effect function
-    pure $ f gatCs datum' txOutRef' ctx.txInfo
+    pure $ f atSymbol datum' txOutRef' ctx.txInfo

agora/Agora/Effect/GovernorMutation.hs

@@ -21,32 +21,43 @@ module Agora.Effect.GovernorMutation (
 import Agora.Effect (makeEffect)
 import Agora.Governor (
   GovernorDatum,
-  PGovernorDatum,
-  pisGovernorDatumValid,
+  GovernorRedeemer (MutateGovernor),
+  PGovernorDatum (PGovernorDatum),
+  PGovernorRedeemer,
  )
-import Agora.Plutarch.Orphans ()
-import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass)
-import Plutarch.Api.V1 (
-  PTxOutRef,
+import Agora.Proposal (PProposalId)
+import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
+import Agora.Utils (pfindInputWithStateThreadToken, pfindOutputWithStateThreadToken)
+import Generics.SOP qualified as SOP
+import Plutarch.Api.V1 (PCurrencySymbol)
+import Plutarch.Api.V2 (
+  PScriptHash,
+  PScriptPurpose (PSpending),
   PValidator,
-  PValue,
  )
-import Plutarch.Api.V1.ScriptContext (pisScriptAddress, ptryFindDatum)
-import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
 import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
   PDataFields,
  )
-import Plutarch.Extra.Maybe (
-  passertPDJust,
-  passertPJust,
+import Plutarch.Extra.Field (pletAll, pletAllC)
+import Plutarch.Extra.IsData (
+  DerivePConstantViaDataList (DerivePConstantViaDataList),
+  PlutusTypeDataList,
+  ProductIsData (ProductIsData),
  )
-import Plutarch.Extra.TermCont (pguardC, pletFieldsC)
+import Plutarch.Extra.Maybe (passertPJust, pfromJust)
+import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
+import Plutarch.Extra.ScriptContext (
+  pisScriptAddress,
+  pscriptHashFromAddress,
+  ptryFromOutputDatum,
+  ptryFromRedeemer,
+ )
+import Plutarch.Extra.Tagged (PTagged)
 import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
-import PlutusLedgerApi.V1 (TxOutRef)
-import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusTx qualified
 
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
+
 --------------------------------------------------------------------------------
 
 {- | Haskell-level datum for the governor mutation effect script.
@@ -54,8 +65,8 @@ import PlutusTx qualified
      @since 0.1.0
 -}
 data MutateGovernorDatum = MutateGovernorDatum
-  { governorRef :: TxOutRef
-  -- ^ Referenced governor state UTXO should be updated by the effect.
+  { oldDatum :: GovernorDatum
+  -- ^ The governor datum value on which this effect is valid
   , newDatum :: GovernorDatum
   -- ^ The new settings for the governor.
   }
@@ -65,8 +76,17 @@ data MutateGovernorDatum = MutateGovernorDatum
     , -- | @since 0.1.ç
       Generic
     )
-
-PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData MutateGovernorDatum)
 
 --------------------------------------------------------------------------------
 
@@ -79,7 +99,7 @@ newtype PMutateGovernorDatum (s :: S)
       ( Term
           s
           ( PDataRecord
-              '[ "governorRef" ':= PTxOutRef
+              '[ "oldDatum" ':= PGovernorDatum
                , "newDatum" ':= PGovernorDatum
                ]
           )
@@ -100,16 +120,20 @@ newtype PMutateGovernorDatum (s :: S)
     )
 
 instance DerivePlutusType PMutateGovernorDatum where
-  type DPTStrat _ = PlutusTypeData
+  type DPTStrat _ = PlutusTypeDataList
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
+instance PUnsafeLiftDecl PMutateGovernorDatum where
+  type PLifted PMutateGovernorDatum = MutateGovernorDatum
 
 -- | @since 0.1.0
-deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
+deriving via
+  (DerivePConstantViaDataList MutateGovernorDatum PMutateGovernorDatum)
+  instance
+    (PConstantDecl MutateGovernorDatum)
 
 -- | @since 0.1.0
-deriving anyclass instance PTryFrom PData PMutateGovernorDatum
+deriving anyclass instance PTryFrom PData (PAsData PMutateGovernorDatum)
 
 --------------------------------------------------------------------------------
 
@@ -136,83 +160,137 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum
          * It has valid governor state datum.
          * The datum is exactly the same as the 'newDatum'.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 mutateGovernorValidator ::
-  -- | Lazy precompiled scripts. This is beacuse we need the symbol of GST.
-  AgoraScripts ->
-  ClosedTerm PValidator
-mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
-  \_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
-    datumF <- pletFieldsC @'["newDatum", "governorRef"] datum
-    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums"] txInfo
+  ClosedTerm
+    ( PAsData PScriptHash
+        :--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
+        :--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
+        :--> PValidator
+    )
+mutateGovernorValidator =
+  plam $ \govValidatorHash gstSymbol -> makeEffect @(PAsData PMutateGovernorDatum) $
+    \_gatCs (pfromData -> effectDatum) _ txInfo -> unTermCont $ do
+      effectDatumF <- pletAllC effectDatum
+      txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
 
-    let mint :: Term _ (PBuiltinList _)
-        mint = pto $ pto $ pto $ pfromData txInfoF.mint
+      --------------------------------------------------------------------------
 
-    pguardC "Nothing should be minted/burnt other than GAT" $
-      plength # mint #== 1
-
-    -- Only two script inputs are alloed: one from the effect, one from the governor.
-    pguardC "Only self and governor script inputs are allowed" $
-      pfoldr
-        # phoistAcyclic
-          ( plam $ \inInfo count ->
-              let address = pfield @"address" #$ pfield @"resolved" # inInfo
-               in pif
-                    (pisScriptAddress # address)
-                    (count + 1)
-                    count
-          )
-        # (0 :: Term _ PInteger)
-        # pfromData txInfoF.inputs
-        #== 2
-
-    -- Find the governor input by looking for GST.
-    let inputWithGST =
-          passertPJust # "Governor input not found" #$ pfind
-            # phoistAcyclic
-              ( plam $ \inInfo ->
-                  let value = pfield @"value" #$ pfield @"resolved" # inInfo
-                   in gstValueOf # value #== 1
+      scriptInputs <-
+        pletC $
+          pfilter
+            # plam
+              ( \inInfo ->
+                  pisScriptAddress
+                    #$ pfield @"address"
+                    #$ pfield @"resolved"
+                    # inInfo
               )
             # pfromData txInfoF.inputs
 
-    govInInfo <- pletFieldsC @'["outRef", "resolved"] $ inputWithGST
+      -- Only two script inputs are alloed: one from the effect script, another from the governor.
+      pguardC "Only self and governor script inputs are allowed" $
+        plength # scriptInputs #== 2
 
-    -- The effect can only modify the governor UTXO referenced in the datum.
-    pguardC "Can only modify the pinned governor" $
-      govInInfo.outRef #== datumF.governorRef
+      let
+        governorInput =
+          passertPJust
+            # "Governor UTXO should carry GST"
+            # ( pfindInputWithStateThreadToken
+                  # pfromData gstSymbol
+                  # scriptInputs
+              )
 
-    -- The transaction can only have one output, which should be sent to the governor.
-    pguardC "Only governor output is allowed" $
-      plength # pfromData txInfoF.outputs #== 1
+        governorRef = pfield @"outRef" # governorInput
 
-    let govAddress = pfield @"address" #$ govInInfo.resolved
-        govOutput' = phead # pfromData txInfoF.outputs
+        governorInputDatum =
+          ptrace "Resolve governor input datum" $
+            pfromData $
+              ptryFromOutputDatum @(PAsData PGovernorDatum)
+                # (pfield @"datum" #$ pfield @"resolved" # governorInput)
+                # txInfoF.datums
 
-    govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput'
+        inputProposalId = pfield @"nextProposalId" # governorInputDatum
 
-    pguardC "No output to the governor" $
-      govOutput.address #== govAddress
+        expectedInputDatum =
+          replaceProposalId # effectDatumF.oldDatum # inputProposalId
 
-    pguardC "Governor output doesn't carry the GST" $
-      gstValueOf # govOutput.value #== 1
+      pguardC "Governor input should be valid" $
+        ( pletAll governorInput $ \inputF ->
+            let
+              isGovernorInput =
+                foldl1
+                  (#&&)
+                  [ ptraceIfFalse "Can only modify the pinned governor datum" $
+                      governorInputDatum #== expectedInputDatum
+                  , ptraceIfFalse "Governor validator run" $
+                      let inputScriptHash =
+                            pfromJust
+                              #$ pscriptHashFromAddress
+                              #$ pfield @"address"
+                              # inputF.resolved
+                       in inputScriptHash #== pfromData govValidatorHash
+                  ]
+             in
+              isGovernorInput
+        )
+
+      let
+        governorRedeemer =
+          pfromData $
+            passertPJust
+              # "Governor redeemer should be resolved"
+              #$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
+              # mkRecordConstr PSpending (#_0 .= governorRef)
+              # txInfoF.redeemers
+
+      pguardC "Spend governor with redeemer MutateGovernor" $
+        governorRedeemer #== pconstant MutateGovernor
+
+      ----------------------------------------------------------------------------
+
+      let
+        governorOutput =
+          passertPJust
+            # "No governor output found"
+            #$ pfindOutputWithStateThreadToken
+            # pfromData gstSymbol
+            # pfromData txInfoF.outputs
 
-    let governorOutputDatumHash =
-          passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash
         governorOutputDatum =
-          passertPJust @PGovernorDatum # "Governor output datum not found"
-            #$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
+          ptrace "Resolve governor outoput datum" $
+            pfromData $
+              ptryFromOutputDatum @(PAsData PGovernorDatum)
+                # (pfield @"datum" # governorOutput)
+                # txInfoF.datums
 
-    -- Ensure the output governor datum is what we want.
-    pguardC "Unexpected governor datum" $ datumF.newDatum #== governorOutputDatum
-    pguardC "New governor datum should be valid" $ pisGovernorDatumValid # governorOutputDatum
+        expectedOutputDatum =
+          replaceProposalId # effectDatumF.newDatum # inputProposalId
 
-    return $ popaque $ pconstant ()
+      pguardC "New governor datum correct" $
+        governorOutputDatum #== expectedOutputDatum
+
+      return $ popaque $ pconstant ()
   where
-    -- Get the amount of GST in the a given value.
-    gstValueOf :: Term s (PValue _ _ :--> PInteger)
-    gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
-      where
-        AssetClass (cs, tn) = governorSTAssetClass as
+    replaceProposalId ::
+      ClosedTerm
+        ( PGovernorDatum
+            :--> PAsData PProposalId
+            :--> PGovernorDatum
+        )
+    replaceProposalId = plam $ \datum proposalId ->
+      pletAll datum $ \datumF ->
+        mkRecordConstr
+          PGovernorDatum
+          ( #proposalThresholds
+              .= datumF.proposalThresholds
+              .& #nextProposalId
+              .= proposalId
+              .& #proposalTimings
+              .= datumF.proposalTimings
+              .& #createProposalTimeRangeMaxWidth
+              .= datumF.createProposalTimeRangeMaxWidth
+              .& #maximumCreatedProposalsPerStake
+              .= datumF.maximumCreatedProposalsPerStake
+          )

agora/Agora/Effect/NoOp.hs

@@ -8,9 +8,10 @@ A dumb effect that only burns its GAT.
 module Agora.Effect.NoOp (noOpValidator, PNoOp) where
 
 import Agora.Effect (makeEffect)
-import Agora.Plutarch.Orphans ()
-import Plutarch.Api.V1 (PValidator)
-import PlutusLedgerApi.V1.Value (CurrencySymbol)
+import Agora.SafeMoney (AuthorityTokenTag)
+import Plutarch.Api.V1 (PCurrencySymbol)
+import Plutarch.Api.V2 (PValidator)
+import Plutarch.Extra.Tagged (PTagged)
 
 {- | Dummy datum for NoOp effect.
 
@@ -37,8 +38,9 @@ instance PTryFrom PData (PAsData PNoOp)
 
 {- | Dummy effect which can only burn its GAT.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
-noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
-noOpValidator curr = makeEffect curr $
-  \_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())
+noOpValidator :: ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
+noOpValidator = plam $
+  makeEffect $
+    \_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

agora/Agora/Effect/TreasuryWithdrawal.hs

@@ -9,32 +9,50 @@ An Effect that withdraws treasury deposit
 -}
 module Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (..),
-  PTreasuryWithdrawalDatum (..),
+  PTreasuryWithdrawalDatum (PTreasuryWithdrawalDatum),
   treasuryWithdrawalValidator,
 ) where
 
 import Agora.Effect (makeEffect)
-import Agora.Plutarch.Orphans ()
-import Plutarch.Api.V1 (
+import Agora.SafeMoney (AuthorityTokenTag)
+import Agora.Utils (pisSubValueOf, psubtractSortedValue, puncurryTuple)
+import Generics.SOP qualified as SOP
+import Plutarch.Api.Internal.Hashing (hashData)
+import Plutarch.Api.V1 (PCredential, PCurrencySymbol, PValue)
+import Plutarch.Api.V1.Address (PCredential (PPubKeyCredential))
+import Plutarch.Api.V1.Value (pforgetPositive)
+import Plutarch.Api.V2 (
   AmountGuarantees (Positive),
   KeyGuarantees (Sorted),
-  PCredential (..),
   PTuple,
+  PTxInInfo,
+  PTxOut,
   PValidator,
-  PValue,
-  ptuple,
  )
-import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisPubKey)
-import "plutarch" Plutarch.Api.V1.Value (pnormalize)
+import Plutarch.Api.V2.Tx (POutputDatum (..))
 import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
   PDataFields,
  )
-import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
+import Plutarch.Extra.Field (pletAllC)
+import Plutarch.Extra.IsData (
+  DerivePConstantViaDataList (
+    DerivePConstantViaDataList
+  ),
+  ProductIsData (ProductIsData),
+ )
+import Plutarch.Extra.ScriptContext (pisPubKey)
+import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Traversable (pfoldMap)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import PlutusLedgerApi.V1.Credential (Credential)
-import PlutusLedgerApi.V1.Value (CurrencySymbol, Value)
+import PlutusLedgerApi.V1.Scripts (DatumHash (DatumHash))
+import PlutusLedgerApi.V1.Value (Value)
 import PlutusTx qualified
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
+  pguardC,
+  pletC,
+  pletFieldsC,
+ )
 
 {- | Datum that encodes behavior of Treasury Withdrawal effect.
 
@@ -56,12 +74,17 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
     , -- | @since 0.1.0
       Generic
     )
-
--- | @since 0.1.0
-PlutusTx.makeLift ''TreasuryWithdrawalDatum
-
--- | @since 0.1.0
-PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData TreasuryWithdrawalDatum)
 
 {- | Haskell-level version of 'TreasuryWithdrawalDatum'.
 
@@ -91,7 +114,7 @@ newtype PTreasuryWithdrawalDatum (s :: S)
     )
 
 instance DerivePlutusType PTreasuryWithdrawalDatum where
-  type DPTStrat _ = PlutusTypeData
+  type DPTStrat _ = PlutusTypeNewtype
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
@@ -99,12 +122,12 @@ instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
+  (DerivePConstantViaDataList TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
   instance
     (PConstantDecl TreasuryWithdrawalDatum)
 
 -- | @since 0.1.0
-instance PTryFrom PData PTreasuryWithdrawalDatum
+instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
 
 {- | Withdraws given list of values to specific target addresses.
      It can be evoked by burning GAT. The transaction should have correct
@@ -119,77 +142,156 @@ instance PTryFrom PData PTreasuryWithdrawalDatum
 
        2. Left over assets should be redirected back to Treasury
 
-     It can be more flexiable over...
+    The output order should be:
 
-     - The number of outputs themselves
+      1. Receiver outputs. They should be in the same order as the 'receivers' field of the datum.
 
-     @since 0.1.0
+      2. Other outputs: treasury outputs, colleteral outputs, etc.
+
+     @since 1.0.0
 -}
-treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
-treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
-  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> unTermCont $ do
-    datum <- pletFieldsC @'["receivers", "treasuries"] datum'
-    txInfo <- pletFieldsC @'["outputs", "inputs"] txInfo'
-    PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef' # pfromData txInfo.inputs
-    effInput <- pletFieldsC @'["address", "value"] $ txOut
-    outputValues <-
-      pletC $
-        pmap
-          # plam
-            ( \txOut' -> unTermCont $ do
-                txOut <- pletFieldsC @'["address", "value"] $ txOut'
-                let cred = pfield @"credential" # pfromData txOut.address
-                pure . pdata $ ptuple # cred # txOut.value
-            )
-          # pfromData txInfo.outputs
-    inputValues <-
-      pletC $
-        pmap
-          # plam
-            ( \((pfield @"resolved" #) -> txOut') -> unTermCont $ do
-                txOut <- pletFieldsC @'["address", "value"] $ txOut'
-                let cred = pfield @"credential" # pfromData txOut.address
-                pure . pdata $ ptuple # cred # txOut.value
-            )
-          # txInfo.inputs
-    let ofTreasury =
-          pfilter
-            # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
-        sumValues = phoistAcyclic $
-          plam $ \v ->
-            pnormalize
-              #$ pfoldr
-              # plam (\(pfromData . (pfield @"_1" #) -> x) y -> x <> y)
-              # mempty
-              # v
-        treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
-        treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
-        receiverValuesSum = sumValues # datum.receivers
-        -- Constraints
-        outputContentMatchesRecivers =
-          pall # plam (\out -> pelem # out # outputValues)
-            #$ datum.receivers
-        excessShouldBePaidToInputs =
-          treasuryOutputValuesSum <> receiverValuesSum #== treasuryInputValuesSum
-        shouldNotPayToEffect =
-          pnot #$ pany
-            # plam
-              ( \x ->
-                  effInput.address #== pfield @"address" # x
-              )
-            # pfromData txInfo.outputs
-        inputsAreOnlyTreasuriesOrCollateral =
-          pall
-            # plam
-              ( \((pfield @"_0" #) . pfromData -> cred) ->
-                  cred #== pfield @"credential" # effInput.address
-                    #|| pelem # cred # datum.treasuries
-                    #|| pisPubKey # pfromData cred
-              )
-            # inputValues
+treasuryWithdrawalValidator ::
+  forall (s :: S).
+  Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
+treasuryWithdrawalValidator = plam $
+  makeEffect @(PAsData PTreasuryWithdrawalDatum) $
+    \_cs (pfromData -> datum) effectInputRef txInfo -> unTermCont $ do
+      datumF <- pletAllC datum
+      txInfoF <- pletFieldsC @'["outputs", "inputs"] txInfo
 
-    pguardC "Transaction should not pay to effects" shouldNotPayToEffect
-    pguardC "Transaction output does not match receivers" outputContentMatchesRecivers
-    pguardC "Remainders should be returned to the treasury" excessShouldBePaidToInputs
-    pguardC "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
-    pure . popaque $ pconstant ()
+      let
+        -- Validate the input and if it's from one of the treasuries,
+        --  return the value.
+        --
+        -- Only effect inputs, treasury inputs and public key inputs are
+        --  allowed.
+        extractTreasuryInputValue ::
+          Term _ (PTxInInfo :--> PValue 'Sorted 'Positive)
+        extractTreasuryInputValue = plam $ \input -> unTermCont $ do
+          inputF <- pletAllC input
+          resolvedF <- pletFieldsC @'["address", "value"] inputF.resolved
+
+          cred <- pletC $ pfield @"credential" # resolvedF.address
+
+          let isEffectInput =
+                ptraceIfTrue "Effect input" $
+                  inputF.outRef #== effectInputRef
+              isTreasuryInput =
+                ptraceIfTrue "Treasury input" $
+                  pelem # pdata cred # datumF.treasuries
+              isPubkeyInput =
+                ptraceIfTrue "Pubkey input" $
+                  pisPubKey # cred
+          pure
+            $ pif
+              (isEffectInput #|| isPubkeyInput)
+              mempty
+            $ pif isTreasuryInput resolvedF.value
+            $ ptraceError "Unknown input"
+
+        treasuryInputAmount =
+          pfoldMap
+            # extractTreasuryInputValue
+            # txInfoF.inputs
+
+        sentAmout =
+          pfoldMap
+            # plam ((puncurryTuple # plam (const id) #) . pfromData)
+            # pfromData datumF.receivers
+
+        treasuryLeftOverAmount =
+          psubtractSortedValue
+            # treasuryInputAmount
+            # sentAmout
+
+        remainingOutputs =
+          ptrace "Check receiver outputs" $
+            checkReceiverOutputs
+              # datumF.receivers
+              # txInfoF.outputs
+
+        extractTreasuryOutputValue ::
+          Term _ (PTxOut :--> PValue 'Sorted 'Positive)
+        extractTreasuryOutputValue = plam $
+          flip (pletFields @'["address", "value", "datum"]) $ \outputF ->
+            let cred = pfield @"credential" # outputF.address
+
+                isTreasuryOutput =
+                  ptraceIfFalse "Should sent to one of the treasuries" $
+                    pelem # pdata cred # datumF.treasuries
+
+                isDatumValid =
+                  ptraceIfFalse "Valid output datum" $
+                    checkOutputDatum # cred # outputF.datum
+             in pif
+                  (isTreasuryOutput #&& isDatumValid)
+                  outputF.value
+                  mempty
+
+        -- Return the value if it'll be sent to one of the treasuries.
+        treasuryOutputAmount =
+          pfoldMap
+            # extractTreasuryOutputValue
+            # remainingOutputs
+
+      pguardC "Unused treasury should stay at treasury validators" $
+        treasuryLeftOverAmount #== pforgetPositive treasuryOutputAmount
+
+      pure . popaque $ pconstant ()
+  where
+    -- Make sure that all the receivers get the correct payment, return the
+    --  remaining outputs.
+    --
+    -- This function is not hoisted cause it's used only once.
+    checkReceiverOutputs ::
+      Term
+        s
+        ( PBuiltinList
+            (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
+            :--> PBuiltinList PTxOut
+            :--> PBuiltinList PTxOut
+        )
+    checkReceiverOutputs = pfix #$ plam $ \self receivers outputs ->
+      pelimList
+        ( \r rs ->
+            pelimList
+              ( \o os -> pletFields @'["value", "address", "datum"] o $ \oF ->
+                  let isValidReceiverOutput =
+                        puncurryTuple
+                          # plam
+                            ( \expCred expVal ->
+                                foldl1
+                                  (#&&)
+                                  [ ptraceIfFalse "Valid credential" $
+                                      expCred #== pfield @"credential" # oF.address
+                                  , ptraceIfFalse "Valid value" $
+                                      pisSubValueOf # oF.value # expVal
+                                  , ptraceIfFalse "Valid output datum" $
+                                      checkOutputDatum # expCred # oF.datum
+                                  ]
+                            )
+                          # pfromData r
+                   in pif
+                        isValidReceiverOutput
+                        (self # rs # os)
+                        (ptraceError "Invalid receiver output")
+              )
+              (ptraceError "Unable to exhaust receivers")
+              outputs
+        )
+        outputs
+        receivers
+
+    unitDatum = PlutusTx.toData ()
+
+    unitDatumHash = DatumHash $ hashData unitDatum
+
+    checkOutputDatum :: Term s (PCredential :--> POutputDatum :--> PBool)
+    checkOutputDatum = phoistAcyclic $ plam $ \cred datum -> pmatch cred $
+      \case
+        PPubKeyCredential _ -> pcon PTrue
+        _ -> pmatch datum $ \case
+          PNoOutputDatum _ -> pcon PFalse
+          POutputDatum _ -> pcon PTrue
+          POutputDatumHash ((pfield @"datumHash" #) -> hash) ->
+            pconstant unitDatumHash #== hash

agora/Agora/Governor.hs

@@ -21,11 +21,13 @@ module Agora.Governor (
   pgetNextProposalId,
   getNextProposalId,
   pisGovernorDatumValid,
+  presolveGovernorRedeemer,
 ) where
 
+import Agora.Aeson.Orphans ()
 import Agora.Proposal (
-  PProposalId (..),
-  PProposalThresholds (..),
+  PProposalId (PProposalId),
+  PProposalThresholds,
   ProposalId (ProposalId),
   ProposalThresholds,
   pisProposalThresholdsValid,
@@ -38,22 +40,37 @@ import Agora.Proposal.Time (
   pisMaxTimeRangeWidthValid,
   pisProposalTimingConfigValid,
  )
-import Agora.SafeMoney (GTTag)
-import Data.Tagged (Tagged (..))
-import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
-  PDataFields,
- )
+import Agora.SafeMoney (GTTag, GovernorSTTag)
+import Data.Aeson qualified as Aeson
+import Data.Tagged (Tagged)
+import Generics.SOP qualified as SOP
+import Optics.TH (makeFieldLabelsNoPrefix)
+import Plutarch.Api.V1.Scripts (PRedeemer)
+import Plutarch.Api.V2 (KeyGuarantees (Unsorted), PMap, PScriptPurpose (PSpending), PTxInInfo)
+import Plutarch.DataRepr (PDataFields)
+import Plutarch.Extra.AssetClass (AssetClass, PAssetClass)
+import Plutarch.Extra.Bind (PBind ((#>>=)))
+import Plutarch.Extra.Field (pletAll)
+import Plutarch.Extra.Function (pflip)
+import Plutarch.Extra.Functor (PFunctor (pfmap))
 import Plutarch.Extra.IsData (
-  DerivePConstantViaEnum (..),
-  EnumIsData (..),
+  DerivePConstantViaDataList (DerivePConstantViaDataList),
+  DerivePConstantViaEnum (DerivePConstantEnum),
+  EnumIsData (EnumIsData),
+  PlutusTypeDataList,
   PlutusTypeEnumData,
+  ProductIsData (ProductIsData),
  )
-import Plutarch.Extra.TermCont (pletFieldsC)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
+import Plutarch.Extra.Maybe (pjust, pnothing)
+import Plutarch.Extra.Record (mkRecordConstr, (.=))
+import Plutarch.Extra.ScriptContext (ptryFromRedeemer)
+import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Value (passetClassValueOfT)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import PlutusLedgerApi.V1 (TxOutRef)
-import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusTx qualified
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
 
 --------------------------------------------------------------------------------
 
@@ -71,9 +88,8 @@ data GovernorDatum = GovernorDatum
   --   Will get copied over upon the creation of proposals.
   , createProposalTimeRangeMaxWidth :: MaxTimeRangeWidth
   -- ^ The maximum valid duration of a transaction that creats a proposal.
-  , maximumProposalsPerStake :: Integer
-  -- ^ The maximum number of unfinished proposals that a stake is allowed to be
-  --   associated to.
+  , maximumCreatedProposalsPerStake :: Integer
+  -- ^ The maximum number of proposals created by any given stakes.
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -81,9 +97,17 @@ data GovernorDatum = GovernorDatum
     , -- | @since 0.1.0
       Generic
     )
-
--- | @since 0.1.0
-PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData GovernorDatum)
 
 {- | Redeemer for Governor script. The governor has two primary
      responsibilities:
@@ -140,6 +164,14 @@ data Governor = Governor
     , -- | @since 0.2.0
       Show
     )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      Aeson.ToJSON
+    , -- | @since 1.0.0
+      Aeson.FromJSON
+    )
+
+makeFieldLabelsNoPrefix ''Governor
 
 --------------------------------------------------------------------------------
 
@@ -156,7 +188,7 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
              , "nextProposalId" ':= PProposalId
              , "proposalTimings" ':= PProposalTimingConfig
              , "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
-             , "maximumProposalsPerStake" ':= PInteger
+             , "maximumCreatedProposalsPerStake" ':= PInteger
              ]
         )
   }
@@ -173,20 +205,25 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
       PDataFields
     , -- | @since 0.1.0
       PEq
+    , -- | @since 0.2.1
+      PShow
     )
 
 -- | @since 0.2.0
 instance DerivePlutusType PGovernorDatum where
-  type DPTStrat _ = PlutusTypeData
+  type DPTStrat _ = PlutusTypeDataList
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
+instance PUnsafeLiftDecl PGovernorDatum where type PLifted _ = GovernorDatum
 
 -- | @since 0.1.0
-deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
+deriving via
+  (DerivePConstantViaDataList GovernorDatum PGovernorDatum)
+  instance
+    (PConstantDecl GovernorDatum)
 
 -- | @since 0.1.0
-deriving anyclass instance PTryFrom PData PGovernorDatum
+deriving anyclass instance PTryFrom PData (PAsData PGovernorDatum)
 
 {- | Plutarch-level version of 'GovernorRedeemer'.
 
@@ -232,7 +269,7 @@ deriving via (DerivePConstantViaEnum GovernorRedeemer PGovernorRedeemer) instanc
 
      @since 0.1.0
 -}
-pgetNextProposalId :: Term s (PProposalId :--> PProposalId)
+pgetNextProposalId :: forall (s :: S). Term s (PProposalId :--> PProposalId)
 pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1
 
 {- | Get next proposal id.
@@ -248,7 +285,7 @@ getNextProposalId (ProposalId pid) = ProposalId $ pid + 1
 
      @since 0.1.0
 -}
-pisGovernorDatumValid :: Term s (PGovernorDatum :--> PBool)
+pisGovernorDatumValid :: forall (s :: S). Term s (PGovernorDatum :--> PBool)
 pisGovernorDatumValid = phoistAcyclic $
   plam $ \datum -> unTermCont $ do
     datumF <-
@@ -269,3 +306,53 @@ pisGovernorDatumValid = phoistAcyclic $
         , ptraceIfFalse "time range valid" $
             pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
         ]
+
+{- | Find the governor input and resolve the corresponding governor redeemer,
+     given the assetclass of GST.
+
+     @since 1.0.0
+-}
+presolveGovernorRedeemer ::
+  forall (s :: S).
+  Term
+    s
+    ( PTagged GovernorSTTag PAssetClass
+        :--> PBuiltinList PTxInInfo
+        :--> PMap 'Unsorted PScriptPurpose PRedeemer
+        :--> PMaybe PGovernorRedeemer
+    )
+presolveGovernorRedeemer = phoistAcyclic $
+  plam $ \gstClass inputs redeemers ->
+    let governorInputRef =
+          pfindJust
+            # plam
+              ( flip pletAll $ \inputF ->
+                  let value = pfield @"value" # inputF.resolved
+                      isGovernorInput =
+                        passetClassValueOfT
+                          # gstClass
+                          # value
+                          #== 1
+                   in pif
+                        isGovernorInput
+                        (pjust # inputF.outRef)
+                        pnothing
+              )
+            # inputs
+
+        governorScriptPurpose =
+          pfmap
+            # plam
+              ( \ref ->
+                  mkRecordConstr
+                    PSpending
+                    (#_0 .= ref)
+              )
+            # governorInputRef
+
+        governorRedeemer =
+          governorScriptPurpose
+            #>>= pflip
+            # ptryFromRedeemer @(PAsData PGovernorRedeemer)
+            # redeemers
+     in pfmap # plam pfromData # governorRedeemer

agora/Agora/Governor/Scripts.hs

@@ -21,8 +21,8 @@ import Agora.AuthorityToken (
   singleAuthorityTokenBurned,
  )
 import Agora.Governor (
-  GovernorRedeemer (..),
   PGovernorDatum (PGovernorDatum),
+  PGovernorRedeemer (..),
   pgetNextProposalId,
   pisGovernorDatumValid,
  )
@@ -35,52 +35,43 @@ import Agora.Proposal (
   pneutralOption,
   pwinner,
  )
-import Agora.Proposal.Time (createProposalStartingTime)
-import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
+import Agora.Proposal.Time (pvalidateProposalStartingTime)
+import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
 import Agora.Stake (
-  PProposalLock (..),
-  PStakeDatum (..),
   pnumCreatedProposals,
+  presolveStakeInputDatum,
  )
-import Agora.Utils (
-  mustFindDatum',
-  validatorHashToAddress,
- )
-import Plutarch.Api.V1 (
-  PAddress,
-  PCurrencySymbol,
-  PDatumHash,
-  PMap,
-  PMintingPolicy,
-  PScriptPurpose (PMinting, PSpending),
-  PTxOut,
-  PValidator,
-  PValidatorHash,
- )
-import Plutarch.Api.V1.AssetClass (
-  passetClass,
-  passetClassValueOf,
- )
-import Plutarch.Api.V1.ScriptContext (
-  pfindOutputsToAddress,
+import Agora.Utils (phashDatum, ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
+import Data.Function (on)
+import Plutarch.Api.V1 (PCurrencySymbol)
+import Plutarch.Api.V1.AssocMap (plookup)
+import Plutarch.Api.V1.AssocMap qualified as AssocMap
+import Plutarch.Api.V2 (PDatum, PMintingPolicy, PScriptHash, PScriptPurpose (PMinting, PSpending), PTxOut, PTxOutRef, PValidator)
+import Plutarch.Api.V2.Tx (POutputDatum (..))
+import Plutarch.Extra.AssetClass (PAssetClassData, passetClass)
+import Plutarch.Extra.Field (pletAll, pletAllC)
+import Plutarch.Extra.Maybe (passertPJust, pfromMaybe, pjust, pmaybeData, pnothing)
+import Plutarch.Extra.Ord (POrdering (..), pcompareBy, pfromOrd, psort)
+import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
+import Plutarch.Extra.ScriptContext (
   pfindTxInByTxOutRef,
   pisUTXOSpent,
   pscriptHashFromAddress,
-  ptryFindDatum,
+  pscriptHashToTokenName,
+  ptryFromOutputDatum,
   pvalueSpent,
  )
-import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
-import Plutarch.Extra.Field (pletAllC)
-import Plutarch.Extra.IsData (pmatchEnumFromData)
-import Plutarch.Extra.List (pfirstJust)
-import Plutarch.Extra.Map (
-  plookup,
-  plookup',
+import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Value (passetClassValueOf, psymbolValueOf)
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
+import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
+  pguardC,
+  pletC,
+  pletFieldsC,
+  pmatchC,
+  ptryFromC,
  )
-import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pisDJust)
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
-import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
-import PlutusLedgerApi.V1 (TxOutRef)
 
 --------------------------------------------------------------------------------
 
@@ -109,41 +100,63 @@ import PlutusLedgerApi.V1 (TxOutRef)
   NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator.
         We /can't/ really check this in the policy, otherwise we create a cyclic reference issue.
 
-  @since 0.1.0
+  @since 1.0.0
 -}
-governorPolicy :: TxOutRef -> ClosedTerm PMintingPolicy
-governorPolicy initialSpend =
-  plam $ \_ ctx' -> unTermCont $ do
-    let oref = pconstant initialSpend
+governorPolicy :: ClosedTerm (PAsData PTxOutRef :--> PMintingPolicy)
+governorPolicy =
+  plam $ \initialSpend _ ctx -> unTermCont $ do
+    PMinting ((pfield @"_0" #) -> gstSymbol) <-
+      pmatchC (pfromData $ pfield @"purpose" # ctx)
 
-    PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC (pfromData $ pfield @"purpose" # ctx')
-    let ownAssetClass = passetClass # ownSymbol # pconstant ""
-        txInfo = pfromData $ pfield @"txInfo" # ctx'
+    let txInfo = pfromData $ pfield @"txInfo" # ctx
 
-    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "validRange"] txInfo
+    txInfoF <-
+      pletFieldsC
+        @'[ "mint"
+          , "inputs"
+          , "outputs"
+          , "datums"
+          , "validRange"
+          ]
+        txInfo
 
     pguardC "Referenced utxo should be spent" $
-      pisUTXOSpent # oref # txInfoF.inputs
+      pisUTXOSpent # pfromData initialSpend # txInfoF.inputs
 
     pguardC "Exactly one token should be minted" $
-      psymbolValueOf # ownSymbol # txInfoF.mint #== 1
-        #&& passetClassValueOf # txInfoF.mint # ownAssetClass #== 1
+      let vMap = pfromData $ pto txInfoF.mint
+          tnMap =
+            passertPJust
+              # "GST symbol entry"
+              #$ plookup
+              # gstSymbol
+              # vMap
+       in tnMap #== AssocMap.psingleton # pconstant "" # 1
 
-    govOutput <-
-      pletC $
-        passertPJust
-          # "Governor output not found"
-            #$ pfind
-          # plam
-            ( \((pfield @"value" #) -> value) ->
-                psymbolValueOf # ownSymbol # value #== 1
-            )
-          # pfromData txInfoF.outputs
+    let governorOutputDatum =
+          passertPJust
+            # "Governor output should present"
+            #$ pfindJust
+            # plam
+              ( flip (pletFields @'["value", "datum"]) $ \txOutF ->
+                  let isGovernorUTxO =
+                        psymbolValueOf
+                          # gstSymbol
+                          # txOutF.value
+                          #== 1
 
-    let datumHash = pfield @"datumHash" # govOutput
-        datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
+                      governorDatum =
+                        ptrace "Resolve governor datum" $
+                          pfromData $
+                            ptryFromOutputDatum @(PAsData PGovernorDatum)
+                              # txOutF.datum
+                              # txInfoF.datums
+                   in pif isGovernorUTxO (pjust # governorDatum) pnothing
+              )
+            # pfromData txInfoF.outputs
 
-    pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum
+    pguardC "Governor output datum valid" $
+      pisGovernorDatumValid # governorOutputDatum
 
     pure $ popaque $ pconstant ()
 
@@ -231,359 +244,360 @@ governorPolicy initialSpend =
      - Exactly one GAT is burnt in the transaction.
      - Said GAT is tagged by the effect.
 
-     @since 0.1.0
+     == Arguments
+
+     Following arguments should be provided(in this order):
+     1. proposal validator address
+     2. state ST symbol
+     3. governor ST symbol
+     4. proposal ST symbol
+     5. authority token symbol.
+
+     @since 1.0.0
 -}
 governorValidator ::
   -- | Lazy precompiled scripts.
-  AgoraScripts ->
-  ClosedTerm PValidator
-governorValidator as =
-  plam $ \datum' redeemer' ctx' -> unTermCont $ do
-    ctxF <- pletAllC ctx'
+  ClosedTerm
+    ( PAsData PScriptHash
+        :--> PAsData (PTagged StakeSTTag PAssetClassData)
+        :--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
+        :--> PAsData (PTagged ProposalSTTag PCurrencySymbol)
+        :--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
+        :--> PValidator
+    )
+governorValidator =
+  plam $ \proposalScriptHash sstClass gstSymbol pstSymbol' atSymbol' datum redeemer ctx -> unTermCont $ do
+    atSymbol <- pletC $ pfromData atSymbol'
+    pstSymbol <- pletC $ pfromData pstSymbol'
+    ctxF <- pletAllC ctx
+    txInfo <- pletC $ pfromData ctxF.txInfo
+    txInfoF <-
+      pletFieldsC
+        @'[ "mint"
+          , "inputs"
+          , "outputs"
+          , "datums"
+          , "signatories"
+          , "validRange"
+          ]
+        txInfo
 
-    txInfo' <- pletC $ pfromData $ ctxF.txInfo
-    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo'
+    ----------------------------------------------------------------------------
 
-    PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- pmatchC $ pfromData ctxF.purpose
+    governorInputDatum <- pfromData . fst <$> ptryFromC @(PAsData PGovernorDatum) datum
+    governorInputDatumF <- pletAllC governorInputDatum
 
-    ((pfield @"resolved" #) -> ownInput) <-
+    PSpending ((pfield @"_0" #) -> governorInputRef) <-
+      pmatchC $ pfromData ctxF.purpose
+
+    let governorInput =
+          pfield @"resolved"
+            #$ passertPJust
+            # "Malformed script context: own input not found"
+            #$ pfindTxInByTxOutRef
+            # governorInputRef
+            # txInfoF.inputs
+
+    governorInputF <- pletFieldsC @'["address", "value"] governorInput
+
+    ----------------------------------------------------------------------------
+
+    governorOutputDatum <-
       pletC $
-        passertPJust # "Own input not found"
-          #$ pfindTxInByTxOutRef # ownInputRef # txInfoF.inputs
-    ownInputF <- pletFieldsC @'["address", "value"] ownInput
-    let ownAddress = pfromData $ ownInputF.address
+        passertPJust
+          # "Own output should present"
+          #$ pfindJust
+          # plam
+            ( flip pletAll $ \outputF ->
+                let isGovernorUTxO =
+                      foldl1
+                        (#&&)
+                        [ ptraceIfFalse "Own by governor validator" $
+                            ((#==) `on` (pscriptHashFromAddress #))
+                              outputF.address
+                              governorInputF.address
+                        , ptraceIfFalse "Has governor ST" $
+                            ptaggedSymbolValueOf # pfromData gstSymbol # outputF.value #== 1
+                        ]
 
-    (oldGovernorDatum :: Term _ PGovernorDatum, _) <- ptryFromC datum'
-    oldGovernorDatumF <- pletAllC oldGovernorDatum
+                    datum =
+                      ptrace "Resolve governor datum" $
+                        pfromData $
+                          ptryFromOutputDatum @(PAsData PGovernorDatum)
+                            # outputF.datum
+                            # txInfoF.datums
+                 in pif
+                      isGovernorUTxO
+                      (pjust # datum)
+                      pnothing
+            )
+          # pfromData txInfoF.outputs
 
-    -- Check that GST will be returned to the governor.
-    let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value
-    pguardC "Own input should have exactly one state token" $
-      ownInputGSTAmount #== 1
+    ----------------------------------------------------------------------------
 
-    ownOutputs <- pletC $ pfindOutputsToAddress # txInfoF.outputs # ownAddress
-    pguardC "Exactly one utxo should be sent to the governor" $
-      plength # ownOutputs #== 1
+    pstClass <- pletC $ passetClass # pto pstSymbol # pconstant ""
 
-    ownOutput <- pletFieldsC @'["value", "datumHash"] $ phead # ownOutputs
-    let ownOuputGSTAmount = psymbolValueOf # pgstSymbol # ownOutput.value
-    pguardC "State token should stay at governor's address" $
-      ownOuputGSTAmount #== 1
-
-    -- Check that own output have datum of type 'GovernorDatum'.
-    let outputGovernorStateDatumHash =
-          passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash
-    newGovernorDatum <-
+    getProposalDatum :: Term _ (PTxOut :--> PMaybe PProposalDatum) <-
       pletC $
-        passertPJust # "Ouput governor state datum not found"
-          #$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
+        plam $
+          flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
+            let isProposalUTxO =
+                  passetClassValueOf
+                    # pstClass
+                    # txOutF.value
+                    #== 1
+                    #&& (pfromMaybe # pconstant "" #$ pscriptHashFromAddress # pfromData txOutF.address)
+                    #== pfromData proposalScriptHash
 
-    pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum
+                proposalDatum =
+                  ptrace "Resolve proposal output datum" $
+                    pfromData $
+                      ptryFromOutputDatum
+                        # txOutF.datum
+                        # txInfoF.datums
+             in pif isProposalUTxO (pjust # proposalDatum) pnothing
+
+    ----------------------------------------------------------------------------
+
+    governorRedeemer <- pfromData . fst <$> ptryFromC redeemer
 
     pure $
-      pmatchEnumFromData redeemer' $ \case
-        Just CreateProposal -> unTermCont $ do
+      pmatch governorRedeemer $ \case
+        PCreateProposal -> unTermCont $ do
           -- Check that the transaction advances proposal id.
 
-          let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId
+          let expectedNextProposalId =
+                pgetNextProposalId
+                  # governorInputDatumF.nextProposalId
               expectedNewDatum =
                 mkRecordConstr
                   PGovernorDatum
-                  ( #proposalThresholds .= oldGovernorDatumF.proposalThresholds
-                      .& #nextProposalId .= pdata expectedNextProposalId
-                      .& #proposalTimings .= oldGovernorDatumF.proposalTimings
+                  ( #proposalThresholds
+                      .= governorInputDatumF.proposalThresholds
+                      .& #nextProposalId
+                      .= pdata expectedNextProposalId
+                      .& #proposalTimings
+                      .= governorInputDatumF.proposalTimings
                       .& #createProposalTimeRangeMaxWidth
-                        .= oldGovernorDatumF.createProposalTimeRangeMaxWidth
-                      .& #maximumProposalsPerStake
-                        .= oldGovernorDatumF.maximumProposalsPerStake
+                      .= governorInputDatumF.createProposalTimeRangeMaxWidth
+                      .& #maximumCreatedProposalsPerStake
+                      .= governorInputDatumF.maximumCreatedProposalsPerStake
                   )
-          pguardC "Unexpected governor state datum" $
-            newGovernorDatum #== expectedNewDatum
+
+          pguardC "Only next proposal id gets advanced" $
+            governorOutputDatum #== expectedNewDatum
 
           -- Check that exactly one proposal token is being minted.
 
           pguardC "Exactly one proposal token must be minted" $
-            phasOnlyOneTokenOfCurrencySymbol # ppstSymbol # txInfoF.mint
+            passetClassValueOf # pstClass # txInfoF.mint #== 1
 
           -- Check that a stake is spent to create the propsal,
           --   and the value it contains meets the requirement.
 
-          stakeInputs <-
-            pletC $
-              pfilter
-                # phoistAcyclic
-                  ( plam $
-                      \((pfield @"value" #) . (pfield @"resolved" #) -> value) ->
-                        psymbolValueOf # psstSymbol # value #== 1
-                  )
-                # pfromData txInfoF.inputs
+          let stakeInputDatum =
+                passertPJust
+                  # "Stake input should present"
+                  #$ pfindJust
+                  # ( presolveStakeInputDatum
+                        # (ptoScottEncodingT # pfromData sstClass)
+                        # txInfoF.datums
+                    )
+                  # pfromData txInfoF.inputs
 
-          pguardC "Can process only one stake" $
-            plength # stakeInputs #== 1
+          stakeInputDatumF <- pletAllC stakeInputDatum
 
-          stakeInput <- pletC $ phead # stakeInputs
+          pguardC "Proposals created by the stake must not exceed the limit" $
+            pnumCreatedProposals
+              # stakeInputDatumF.lockedBy
+              #< governorInputDatumF.maximumCreatedProposalsPerStake
 
-          stakeInputF <- pletFieldsC @'["datumHash", "value"] $ pfield @"resolved" # stakeInput
+          let gtThreshold =
+                pfromData $
+                  pfield @"create"
+                    # governorInputDatumF.proposalThresholds
 
-          pguardC "Stake input doesn't have datum" $
-            pisDJust # stakeInputF.datumHash
-
-          let stakeInputDatum = mustFindDatum' @(PAsData PStakeDatum) # stakeInputF.datumHash # txInfoF.datums
-
-          stakeInputDatumF <- pletAllC $ pto $ pfromData stakeInputDatum
-
-          pguardC "Proposals created by the stake must not exceed the number stored in the governor." $
-            pnumCreatedProposals # stakeInputDatumF.lockedBy
-              #< oldGovernorDatumF.maximumProposalsPerStake
+          pguardC "Require minimum amount of GTs" $
+            gtThreshold #<= stakeInputDatumF.stakedAmount
 
           -- Check that the newly minted PST is sent to the proposal validator,
           --   and the datum it carries is legal.
 
-          outputsToProposalValidatorWithStateToken <-
-            pletC $
-              pfilter
-                # phoistAcyclic
-                  ( plam $
-                      \txOut' -> unTermCont $ do
-                        txOut <- pletFieldsC @'["address", "value"] txOut'
+          let proposalOutputDatum =
+                passertPJust
+                  # "Proposal output should present"
+                  #$ pfindJust
+                  # getProposalDatum
+                  # pfromData txInfoF.outputs
 
-                        pure $
-                          txOut.address #== pdata pproposalValidatorAddress
-                            #&& psymbolValueOf # ppstSymbol # txOut.value #== 1
-                  )
-                # pfromData txInfoF.outputs
+          proposalOutputDatumF <- pletAllC proposalOutputDatum
 
-          pguardC "Exactly one UTXO with proposal state token should be sent to the proposal validator" $
-            plength # outputsToProposalValidatorWithStateToken #== 1
-
-          outputDatumHash <- pletC $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken
-
-          proposalOutputDatum' <-
-            pletC $
-              mustFindDatum' @(PAsData PProposalDatum)
-                # outputDatumHash
-                # txInfoF.datums
-
-          proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
-
-          let expectedStartingTime =
-                pfromJust #$ createProposalStartingTime
-                  # oldGovernorDatumF.createProposalTimeRangeMaxWidth
-                  # txInfoF.validRange
-
-              expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
+          let expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
 
           pguardC "Proposal datum correct" $
             foldl1
               (#&&)
               [ ptraceIfFalse "has neutral effect" $
-                  phasNeutralEffect # proposalOutputDatum.effects
+                  phasNeutralEffect # proposalOutputDatumF.effects
               , ptraceIfFalse "votes have valid shape" $
-                  pisEffectsVotesCompatible # proposalOutputDatum.effects # proposalOutputDatum.votes
+                  pisEffectsVotesCompatible # proposalOutputDatumF.effects # proposalOutputDatumF.votes
               , ptraceIfFalse "votes are empty" $
-                  pisVotesEmpty # proposalOutputDatum.votes
+                  pisVotesEmpty # proposalOutputDatumF.votes
               , ptraceIfFalse "id correct" $
-                  proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId
+                  proposalOutputDatumF.proposalId #== governorInputDatumF.nextProposalId
               , ptraceIfFalse "status is Draft" $
-                  proposalOutputDatum.status #== pconstantData Draft
+                  proposalOutputDatumF.status #== pconstantData Draft
               , ptraceIfFalse "cosigners correct" $
-                  plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners
-              , ptraceIfFalse "starting time correct" $
-                  proposalOutputDatum.startingTime #== expectedStartingTime
+                  plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners
+              , ptraceIfFalse "starting time valid" $
+                  pvalidateProposalStartingTime
+                    # governorInputDatumF.createProposalTimeRangeMaxWidth
+                    # txInfoF.validRange
+                    # proposalOutputDatumF.startingTime
               , ptraceIfFalse "copy over configurations" $
-                  proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds
-                    #&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings
+                  proposalOutputDatumF.thresholds
+                    #== governorInputDatumF.proposalThresholds
+                    #&& proposalOutputDatumF.timingConfig
+                    #== governorInputDatumF.proposalTimings
               ]
 
-          -- Check the output stake has been proposly updated.
-          let stakeOutputDatumHash =
-                passertPJust # "Output stake should be presented"
-                  #$ pfirstJust
-                    # phoistAcyclic
-                      ( plam
-                          ( \txOut -> unTermCont $ do
-                              txOutF <- pletFieldsC @'["datumHash", "value"] txOut
-
-                              pure $
-                                pif
-                                  (psymbolValueOf # psstSymbol # txOutF.value #== 1)
-                                  ( pcon $
-                                      PJust $
-                                        passertPDJust # "Output stake datum should be presented"
-                                          # txOutF.datumHash
-                                  )
-                                  (pcon PNothing)
-                          )
-                      )
-                    # pfromData txInfoF.outputs
-
-              stakeOutputDatum =
-                passertPJust @(PAsData PStakeDatum) # "Stake output datum presented"
-                  #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums
-
-              stakeOutputLocks =
-                pfromData $ pfield @"lockedBy" #$ pto $ pfromData stakeOutputDatum
-
-              -- The stake should be locked by the newly created proposal.
-              newLock =
-                mkRecordConstr
-                  PCreated
-                  ( #created .= oldGovernorDatumF.nextProposalId
-                  )
-
-              -- Append new locks to existing locks
-              expectedProposalLocks =
-                pcons # pdata newLock # stakeInputDatumF.lockedBy
-
-          pguardC "Stake output locks correct" $
-            plistEquals # stakeOutputLocks # expectedProposalLocks
-
           pure $ popaque $ pconstant ()
 
-        --------------------------------------------------------------------------
+        ------------------------------------------------------------------------
 
-        Just MintGATs -> unTermCont $ do
-          pguardC "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
+        PMintGATs -> unTermCont $ do
+          pguardC "Governor state should not be changed" $ governorOutputDatum #== governorInputDatum
 
           -- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
 
           pguardC "The governor can only process one proposal at a time" $
-            (psymbolValueOf # ppstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
+            (ptaggedSymbolValueOf # pstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
 
-          proposalInputF <-
-            pletFieldsC @'["datumHash"] $
-              pfield @"resolved"
-                #$ passertPJust
-                # "Proposal input not found"
-                  #$ pfind
-                # plam
-                  ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
-                      txOutF <- pletFieldsC @'["address", "value"] txOut
-
-                      pure $
-                        psymbolValueOf # ppstSymbol # txOutF.value #== 1
-                          #&& txOutF.address #== pdata pproposalValidatorAddress
-                  )
-                # pfromData txInfoF.inputs
-
-          proposalInputDatum <-
-            pletC $
-              mustFindDatum' @(PAsData PProposalDatum)
-                # proposalInputF.datumHash
-                # txInfoF.datums
+          let proposalInputDatum =
+                passertPJust
+                  # "Proposal input not found"
+                  #$ pfindJust
+                  # plam ((getProposalDatum #) . (pfield @"resolved" #))
+                  # pfromData txInfoF.inputs
 
           proposalInputDatumF <-
-            pletFieldsC @'["effects", "status", "thresholds", "votes"] $
-              pto $ pfromData proposalInputDatum
+            pletFieldsC @'["effects", "status", "thresholds", "votes"]
+              proposalInputDatum
 
           -- Check that the proposal state is advanced so that a proposal cannot be executed twice.
 
           pguardC "Proposal must be in locked(executable) state in order to execute effects" $
             proposalInputDatumF.status #== pconstantData Locked
 
-          -- TODO: anything else to check here?
-
           -- Find the highest votes and the corresponding tag.
-          let quorum = pto $ pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
+          let quorum = pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
               neutralOption = pneutralOption # proposalInputDatumF.effects
               finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption
 
           -- The effects of the winner outcome.
-          effectGroup <- pletC $ plookup' # finalResultTag #$ proposalInputDatumF.effects
+          effectGroup <- pletC $ ptryLookup # finalResultTag #$ proposalInputDatumF.effects
 
-          gatCount <- pletC $ plength #$ pto $ pto effectGroup
+          let
+            -- For a given output, check if it contains a single valid GAT.
+            getReceiverScriptHash =
+              plam
+                ( \output -> unTermCont $ do
+                    outputF <- pletFieldsC @'["address", "datum", "value"] output
 
-          pguardC "Required amount of GATs should be minted" $
-            psymbolValueOf # patSymbol # txInfoF.mint #== gatCount
+                    let atAmount =
+                          ptaggedSymbolValueOf
+                            # atSymbol
+                            # outputF.value
 
-          -- Ensure that every GAT goes to one of the effects in the winner effect group.
-          outputsWithGAT <-
-            pletC $
-              pfilter
-                # phoistAcyclic
-                  ( plam
-                      ( \((pfield @"value" #) -> value) ->
-                          0 #< psymbolValueOf # patSymbol # value
+                        handleAuthorityUTxO =
+                          do
+                            receiverScriptHash <-
+                              pletC $
+                                passertPJust
+                                  # "GAT receiver should be a script"
+                                  #$ pscriptHashFromAddress
+                                  # outputF.address
+
+                            effect <-
+                              pletAllC $
+                                passertPJust
+                                  # "Receiver should be in the effect group"
+                                  #$ AssocMap.plookup
+                                  # receiverScriptHash
+                                  # effectGroup
+
+                            let tagToken =
+                                  pmaybeData
+                                    # pconstant ""
+                                    # plam (pscriptHashToTokenName . pfromData)
+                                    # effect.scriptHash
+                                gatAssetClass = passetClass # puntag atSymbol # tagToken
+                                valueGATCorrect =
+                                  passetClassValueOf
+                                    # gatAssetClass
+                                    # outputF.value
+                                    #== 1
+
+                            let outputDatumHash = pmatch outputF.datum $ \case
+                                  POutputDatum d -> phashDatum #$ pfield @"outputDatum" @PDatum # d
+                                  POutputDatumHash h -> pfield @"datumHash" # h
+                                  _ -> ptraceError "expcted effect datum, got nothing"
+
+                                hasCorrectDatum =
+                                  effect.datumHash #== outputDatumHash
+
+                            pguardC "Authority output valid" $
+                              foldr1
+                                (#&&)
+                                [ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # atSymbol # output
+                                , ptraceIfFalse "Correct datum" hasCorrectDatum
+                                , ptraceIfFalse "Value correctly encodes Auth Check script" valueGATCorrect
+                                ]
+
+                            pure $ pjust # receiverScriptHash
+
+                    pmatchC
+                      ( pcompareBy
+                          # pfromOrd
+                          # atAmount
+                          # 1
                       )
-                  )
+                      >>= \case
+                        -- atAmount == 1
+                        PEQ -> handleAuthorityUTxO
+                        -- atAmount < 1
+                        PLT -> pure pnothing
+                        -- atAmount > 1
+                        PGT -> pure $ ptraceError "More than one GAT in one UTxO"
+                )
+
+            -- The sorted hashes of all the GAT receivers.
+            actualReceivers =
+              psort
+                #$ pmapMaybe @PList
+                # getReceiverScriptHash
                 # pfromData txInfoF.outputs
 
-          pguardC "Output GATs is more than minted GATs" $
-            plength # outputsWithGAT #== gatCount
+            expectedReceivers = pkeys @PList # effectGroup
 
-          let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
-              gatOutputValidator' =
-                phoistAcyclic $
-                  plam
-                    ( \effects output' -> unTermCont $ do
-                        output <- pletFieldsC @'["address", "datumHash"] output'
-
-                        let scriptHash =
-                              passertPJust # "GAT receiver is not a script"
-                                #$ pscriptHashFromAddress # output.address
-                            datumHash =
-                              passertPDJust # "Output to effect should have datum"
-                                #$ output.datumHash
-
-                            expectedDatumHash =
-                              passertPJust # "Receiver is not in the effect list"
-                                #$ plookup # scriptHash # effects
-
-                        pure $
-                          foldr1
-                            (#&&)
-                            [ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output'
-                            , ptraceIfFalse "Unexpected datum" $ datumHash #== expectedDatumHash
-                            ]
-                    )
-
-              gatOutputValidator = gatOutputValidator' # effectGroup
-
-          pguardC "GATs valid" $
-            pfoldr
-              # plam
-                ( \txOut r ->
-                    let value = pfield @"value" # txOut
-                        atValue = psymbolValueOf # patSymbol # value
-                     in pif (atValue #== 0) r $
-                          pif (atValue #== 1) (r #&& gatOutputValidator # txOut) $ pconstant False
-                )
-              # pconstant True
-              # pfromData txInfoF.outputs
+          -- This check ensures that it's impossible to send more than one GATs
+          -- to a validator in the winning effect group.
+          pguardC "Each script in the effect group gets a GAT" $
+            plistEqualsBy
+              # plam (\(pfromData -> x) y -> x #== y)
+              # expectedReceivers
+              # actualReceivers
 
           pure $ popaque $ pconstant ()
 
-        --------------------------------------------------------------------------
+        ------------------------------------------------------------------------
+
+        PMutateGovernor -> unTermCont $ do
+          pguardC "Governor output datum is valid" $
+            pisGovernorDatumValid # governorOutputDatum
 
-        Just MutateGovernor -> unTermCont $ do
           -- Check that a GAT is burnt.
           pguardC "One valid GAT burnt" $
-            singleAuthorityTokenBurned patSymbol txInfoF.inputs txInfoF.mint
+            singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint
 
           pure $ popaque $ pconstant ()
-
-        --------------------------------------------------------------------------
-        Nothing -> ptraceError "Unknown redeemer"
-  where
-    -- The currency symbol of authority token.
-    patSymbol :: Term s PCurrencySymbol
-    patSymbol = pconstant $ authorityTokenSymbol as
-
-    -- The currency symbol of the proposal state token.
-    ppstSymbol :: Term s PCurrencySymbol
-    ppstSymbol = pconstant $ proposalSTSymbol as
-
-    -- The address of the proposal validator.
-    pproposalValidatorAddress :: Term s PAddress
-    pproposalValidatorAddress =
-      pconstant $
-        validatorHashToAddress $
-          proposalValidatoHash as
-
-    -- The currency symbol of the stake state token.
-    psstSymbol :: Term s PCurrencySymbol
-    psstSymbol = pconstant $ stakeSTSymbol as
-
-    -- The currency symbol of the governor state token.
-    pgstSymbol :: Term s PCurrencySymbol
-    pgstSymbol = pconstant $ governorSTSymbol as

agora/Agora/Linker.hs

@@ -0,0 +1,193 @@
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+
+module Agora.Linker (linker, AgoraScriptInfo (..)) where
+
+import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
+import Agora.SafeMoney (AuthorityTokenTag, GTTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
+import Data.Aeson qualified as Aeson
+import Data.Map (fromList)
+import Data.Tagged (Tagged (Tagged))
+import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
+import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
+import PlutusLedgerApi.V2 (CurrencySymbol (CurrencySymbol), ScriptHash, TxOutRef, getScriptHash)
+import Ply (
+  AsData (AsData),
+  ScriptRole (MintingPolicyRole, ValidatorRole),
+  (#),
+ )
+import ScriptExport.ScriptInfo (
+  Linker,
+  ScriptExport (..),
+  fetchTS,
+  getParam,
+  toRoledScript,
+  toScript,
+ )
+import Prelude hiding ((#))
+
+{- | Additional information provided after linking.
+
+ @since 1.0.0
+-}
+data AgoraScriptInfo = AgoraScriptInfo
+  { governorAssetClass :: Tagged GovernorSTTag AssetClass
+  , authorityTokenSymbol :: Tagged AuthorityTokenTag CurrencySymbol
+  , proposalAssetClass :: Tagged ProposalSTTag AssetClass
+  , stakeAssetClass :: Tagged StakeSTTag AssetClass
+  , governor :: Governor
+  }
+  deriving stock (Generic, Show)
+  deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)
+
+{- | Links parameterized Agora scripts given parameters.
+
+ @since 1.0.0
+-}
+linker :: Linker Governor (ScriptExport AgoraScriptInfo)
+linker = do
+  govPol <-
+    fetchTS
+      @MintingPolicyRole
+      @'[AsData TxOutRef]
+      "agora:governorPolicy"
+  govVal <-
+    fetchTS
+      @ValidatorRole
+      @'[ AsData ScriptHash
+        , AsData (Tagged StakeSTTag AssetClass)
+        , AsData (Tagged GovernorSTTag CurrencySymbol)
+        , AsData (Tagged ProposalSTTag CurrencySymbol)
+        , AsData (Tagged AuthorityTokenTag CurrencySymbol)
+        ]
+      "agora:governorValidator"
+  stkPol <-
+    fetchTS
+      @MintingPolicyRole
+      @'[AsData (Tagged GTTag AssetClass)]
+      "agora:stakePolicy"
+  stkVal <-
+    fetchTS
+      @ValidatorRole
+      @'[ AsData (Tagged StakeSTTag CurrencySymbol)
+        , AsData (Tagged ProposalSTTag AssetClass)
+        , AsData (Tagged GTTag AssetClass)
+        ]
+      "agora:stakeValidator"
+  prpPol <-
+    fetchTS @MintingPolicyRole
+      @'[AsData (Tagged GovernorSTTag AssetClass)]
+      "agora:proposalPolicy"
+  prpVal <-
+    fetchTS
+      @ValidatorRole
+      @'[ AsData (Tagged StakeSTTag AssetClass)
+        , AsData (Tagged GovernorSTTag CurrencySymbol)
+        , AsData (Tagged ProposalSTTag CurrencySymbol)
+        , AsData Integer
+        ]
+      "agora:proposalValidator"
+  treVal <-
+    fetchTS
+      @ValidatorRole
+      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
+      "agora:treasuryValidator"
+  atkPol <-
+    fetchTS
+      @MintingPolicyRole
+      @'[AsData (Tagged GovernorSTTag AssetClass)]
+      "agora:authorityTokenPolicy"
+  noOpVal <-
+    fetchTS
+      @ValidatorRole
+      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
+      "agora:noOpValidator"
+  treaWithdrawalVal <-
+    fetchTS
+      @ValidatorRole
+      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
+      "agora:treasuryWithdrawalValidator"
+  mutateGovVal <-
+    fetchTS
+      @ValidatorRole
+      @'[ AsData ScriptHash
+        , AsData (Tagged GovernorSTTag CurrencySymbol)
+        , AsData (Tagged AuthorityTokenTag CurrencySymbol)
+        ]
+      "agora:mutateGovernorValidator"
+
+  governor <- getParam
+
+  let govPol' = govPol # AsData governor.gstOutRef
+      govVal' =
+        govVal
+          # AsData propValHash
+          # AsData (Tagged sstAssetClass)
+          # AsData (Tagged gstSymbol)
+          # AsData (Tagged pstSymbol)
+          # AsData (Tagged atSymbol)
+      gstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript govPol'
+      gstAssetClass =
+        AssetClass gstSymbol ""
+      govValHash = scriptHash $ toScript govVal'
+
+      atPol' = atkPol # AsData (Tagged gstAssetClass)
+      atSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript atPol'
+
+      propPol' = prpPol # AsData (Tagged gstAssetClass)
+      propVal' =
+        prpVal
+          # AsData (Tagged sstAssetClass)
+          # AsData (Tagged gstSymbol)
+          # AsData (Tagged pstSymbol)
+          # AsData governor.maximumCosigners
+      propValHash = scriptHash $ toScript propVal'
+      pstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript propPol'
+      pstAssetClass = AssetClass pstSymbol ""
+
+      stakPol' = stkPol # AsData governor.gtClassRef
+      stakVal' =
+        stkVal
+          # AsData (Tagged sstSymbol)
+          # AsData (Tagged pstAssetClass)
+          # AsData governor.gtClassRef
+      sstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript stakPol'
+      stakValTokenName =
+        scriptHashToTokenName $ scriptHash $ toScript stakVal'
+      sstAssetClass = AssetClass sstSymbol stakValTokenName
+
+      treaVal' = treVal # AsData (Tagged atSymbol)
+
+      noOpVal' = noOpVal # AsData (Tagged atSymbol)
+      treaWithdrawalVal' = treaWithdrawalVal # AsData (Tagged atSymbol)
+      mutateGovVal' =
+        mutateGovVal
+          # AsData govValHash
+          # AsData (Tagged gstSymbol)
+          # AsData (Tagged atSymbol)
+
+  return $
+    ScriptExport
+      { scripts =
+          fromList
+            [ ("agora:governorPolicy", toRoledScript govPol')
+            , ("agora:governorValidator", toRoledScript govVal')
+            , ("agora:stakePolicy", toRoledScript stakPol')
+            , ("agora:stakeValidator", toRoledScript stakVal')
+            , ("agora:proposalPolicy", toRoledScript propPol')
+            , ("agora:proposalValidator", toRoledScript propVal')
+            , ("agora:treasuryValidator", toRoledScript treaVal')
+            , ("agora:authorityTokenPolicy", toRoledScript atPol')
+            , ("agora:noOpValidator", toRoledScript noOpVal')
+            , ("agora:treasuryWithdrawalValidator", toRoledScript treaWithdrawalVal')
+            , ("agora:mutateGovernorValidator", toRoledScript mutateGovVal')
+            ]
+      , information =
+          AgoraScriptInfo
+            { governorAssetClass = Tagged gstAssetClass
+            , authorityTokenSymbol = Tagged atSymbol
+            , proposalAssetClass = Tagged pstAssetClass
+            , stakeAssetClass = Tagged sstAssetClass
+            , governor = governor
+            }
+      }

agora/Agora/Plutarch/Orphans.hs

@@ -1,39 +1,86 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-{- FIXME: All of the following instances and
-   types ought to belong in either plutarch or
-   plutarch-extra.
--}
-
 module Agora.Plutarch.Orphans () where
 
-import Plutarch.Api.V1 (PDatumHash (..))
-import Plutarch.Builtin (PIsData (..))
-import Plutarch.Extra.TermCont (ptryFromC)
-import Plutarch.TryFrom (PTryFrom (..))
-import Plutarch.Unsafe (punsafeCoerce)
+import Plutarch.Lift (PConstantDecl (..), PUnsafeLiftDecl (PLifted))
 
-newtype Flip f a b = Flip (f b a) deriving stock (Generic)
+import Data.Bifunctor (Bifunctor (bimap))
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged (Tagged))
+import Data.Traversable (for)
+import Plutarch.Api.V1 (KeyGuarantees (Sorted), PMap)
+import Plutarch.Extra.Tagged (PTagged)
+import PlutusTx qualified
+import PlutusTx.AssocMap qualified as AssocMap
+import Ply (PlyArg)
+import Ply.Plutarch.Class (PlyArgOf)
 
--- | @since 0.1.0
-instance PTryFrom PData (PAsData PDatumHash) where
-  type PTryFromExcess PData (PAsData PDatumHash) = Flip Term PDatumHash
-  ptryFrom' opq = runTermCont $ do
-    (pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
+-- | @since 1.0.0
+instance
+  ( PConstantData k
+  , PConstantData v
+  , Ord k
+  ) =>
+  PConstantDecl (StrictMap.Map k v)
+  where
+  type
+    PConstantRepr (StrictMap.Map k v) =
+      [(PlutusTx.Data, PlutusTx.Data)]
+  type
+    PConstanted (StrictMap.Map k v) =
+      PMap 'Sorted (PConstanted k) (PConstanted v)
+  pconstantToRepr m =
+    bimap
+      PlutusTx.toData
+      PlutusTx.toData
+      <$> StrictMap.toList m
+  pconstantFromRepr m = fmap StrictMap.fromList $
+    for m $ \(x, y) -> do
+      x' <- PlutusTx.fromData x
+      y' <- PlutusTx.fromData y
+      Just (x', y')
 
-    tcont $ \f ->
-      pif
-        -- Blake2b_256 hash: 256 bits/32 bytes.
-        (plengthBS # unwrapped #== 32)
-        (f ())
-        (ptraceError "ptryFrom(PDatumHash): must be 32 bytes long")
+-- | @since 1.0.0
+instance
+  ( PLiftData k
+  , PLiftData v
+  , Ord (PLifted k)
+  ) =>
+  PUnsafeLiftDecl (PMap 'Sorted k v)
+  where
+  type PLifted (PMap 'Sorted k v) = StrictMap.Map (PLifted k) (PLifted v)
 
-    pure (punsafeCoerce opq, pcon $ PDatumHash unwrapped)
+-- | @since 1.0.0
+instance
+  (PlutusTx.ToData k, PlutusTx.ToData v) =>
+  PlutusTx.ToData (StrictMap.Map k v)
+  where
+  toBuiltinData = PlutusTx.toBuiltinData . toAssocMap
+    where
+      toAssocMap :: StrictMap.Map k v -> AssocMap.Map k v
+      toAssocMap = AssocMap.fromList . StrictMap.toAscList
 
--- | @since 0.2.0
-instance PTryFrom PData (PAsData PUnit)
+-- | @since 1.0.0
+instance
+  (PlutusTx.FromData k, PlutusTx.FromData v, Ord k) =>
+  PlutusTx.FromData (StrictMap.Map k v)
+  where
+  fromBuiltinData d = PlutusTx.fromBuiltinData d >>= toStrictMap
+    where
+      toStrictMap :: AssocMap.Map k v -> Maybe (StrictMap.Map k v)
+      toStrictMap m =
+        let l = AssocMap.toList m
+         in if isSorted $ fmap fst l
+              then Just $ StrictMap.fromAscList l
+              else Nothing
 
--- | @since 0.2.0
-instance (PIsData a) => PIsData (PAsData a) where
-  pfromDataImpl = punsafeCoerce
-  pdataImpl = pdataImpl . pfromData
+      isSorted :: forall a. Ord a => [a] -> Bool
+      isSorted [] = True
+      isSorted [_] = True
+      isSorted (x : y : xs) = x < y && isSorted (y : xs)
+
+-- | @since 1.0.0
+type instance PlyArgOf (PTagged tag a) = Tagged tag (PlyArgOf a)
+
+-- | @since 1.0.0
+deriving newtype instance PlyArg a => PlyArg (Tagged tag a)

agora/Agora/Proposal.hs

@@ -9,8 +9,8 @@ Proposal scripts encoding effects that operate on the system.
 -}
 module Agora.Proposal (
   -- * Haskell-land
-
-  -- Proposal (..),
+  ProposalEffectMetadata (..),
+  ProposalEffectGroup,
   ProposalDatum (..),
   ProposalRedeemer (..),
   ProposalStatus (..),
@@ -21,6 +21,8 @@ module Agora.Proposal (
   emptyVotesFor,
 
   -- * Plutarch-land
+  PProposalEffectMetadata (..),
+  PProposalEffectGroup,
   PProposalDatum (..),
   PProposalRedeemer (..),
   PProposalStatus (..),
@@ -41,44 +43,53 @@ module Agora.Proposal (
 ) where
 
 import Agora.Plutarch.Orphans ()
-import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
+import Agora.Proposal.Time (
+  PProposalStartingTime,
+  PProposalTimingConfig,
+  ProposalStartingTime,
+  ProposalTimingConfig,
+ )
 import Agora.SafeMoney (GTTag)
+import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (
-  KeyGuarantees (Unsorted),
-  PDatumHash,
-  PMap,
-  PPubKeyHash,
-  PValidatorHash,
- )
+import Plutarch.Api.V1 (PCredential, PMap)
 import Plutarch.Api.V1.AssocMap qualified as PAssocMap
-import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
-import Plutarch.Extra.Comonad (pextract)
-import Plutarch.Extra.Field (pletAllC)
+import Plutarch.Api.V2 (
+  KeyGuarantees (Sorted),
+  PDatumHash,
+  PMaybeData,
+  PScriptHash,
+ )
+import Plutarch.DataRepr (
+  DerivePConstantViaData (
+    DerivePConstantViaData
+  ),
+  PDataFields,
+ )
+import Plutarch.Extra.Field (pletAll)
 import Plutarch.Extra.Function (pbuiltinUncurry)
 import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (..),
-  DerivePConstantViaEnum (..),
-  EnumIsData (..),
+  DerivePConstantViaDataList (DerivePConstantViaDataList),
+  DerivePConstantViaEnum (DerivePConstantEnum),
+  EnumIsData (EnumIsData),
+  PlutusTypeDataList,
   PlutusTypeEnumData,
   ProductIsData (ProductIsData),
  )
-import Plutarch.Extra.List (pfirstJust)
-import Plutarch.Extra.Map qualified as PM
-import Plutarch.Extra.Map.Unsorted qualified as PUM
 import Plutarch.Extra.Maybe (pfromJust)
-import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
+import Plutarch.Extra.Tagged (PTagged)
 import Plutarch.Lift (
-  DerivePConstantViaNewtype (..),
+  DerivePConstantViaNewtype (DerivePConstantViaNewtype),
   PConstantDecl,
-  PUnsafeLiftDecl (..),
+  PUnsafeLiftDecl (type PLifted),
  )
-import Plutarch.SafeMoney (PDiscrete (..))
-import Plutarch.Show (PShow (..))
-import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
+import Plutarch.Orphans ()
+import PlutusLedgerApi.V2 (Credential, DatumHash, ScriptHash)
 import PlutusTx qualified
-import PlutusTx.AssocMap qualified as AssocMap
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
+import "liqwid-plutarch-extra" Plutarch.Extra.Map qualified as PM
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC)
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -105,8 +116,6 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
-    , -- | @since 0.1.0
-      PlutusTx.UnsafeFromData
     )
 
 {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@@ -151,7 +160,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
 data ProposalStatus
   = -- | A draft proposal represents a proposal that has yet to be realized.
     --
-    --   In effect, this means one which didn't have enough LQ to be a full
+    --   In effect, this means one which didn't have enough GT to be a full
     --   proposal, and needs cosigners to enable that to happen. This is
     --   similar to a "temperature check", but only useful if multiple people
     --   want to pool governance tokens together. If the proposal doesn't get to
@@ -201,8 +210,6 @@ data ProposalStatus
       PlutusTx.FromData
     , -- | @since 0.1.0
       PlutusTx.ToData
-    , -- | @since 0.1.0
-      PlutusTx.UnsafeFromData
     )
     via (EnumIsData ProposalStatus)
 
@@ -210,7 +217,7 @@ data ProposalStatus
      This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
      to 'Proposal's when they are created.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 data ProposalThresholds = ProposalThresholds
   { execute :: Tagged GTTag Integer
@@ -220,9 +227,12 @@ data ProposalThresholds = ProposalThresholds
   --
   -- It is recommended this be a high enough amount, in order to prevent DOS from bad
   -- actors.
+  , toVoting :: Tagged GTTag Integer
+  -- ^ How much GT required to to move into 'VotingReady'.
   , vote :: Tagged GTTag Integer
-  -- ^ How much GT required to allow voting to happen.
-  -- (i.e. to move into 'VotingReady')
+  -- ^ How much GT required to vote on a outcome.
+  , cosign :: Tagged GTTag Integer
+  -- ^ How much GT required to cosign a proposal.
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -232,8 +242,17 @@ data ProposalThresholds = ProposalThresholds
     , -- | @since 0.1.0
       Generic
     )
-
-PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData ProposalThresholds)
 
 {- | Map which encodes the total tally for each result.
      It's important that the "shape" is consistent with the shape of 'effects'.
@@ -249,7 +268,7 @@ PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
      @since 0.1.0
 -}
 newtype ProposalVotes = ProposalVotes
-  { getProposalVotes :: AssocMap.Map ResultTag Integer
+  { getProposalVotes :: StrictMap.Map ResultTag Integer
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -270,8 +289,38 @@ newtype ProposalVotes = ProposalVotes
 
      @since 0.1.0
 -}
-emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
-emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
+emptyVotesFor :: forall a. StrictMap.Map ResultTag a -> ProposalVotes
+emptyVotesFor = ProposalVotes . StrictMap.mapWithKey (const . const 0)
+
+-- | @since 1.0.0
+data ProposalEffectMetadata = ProposalEffectMetadata
+  { datumHash :: DatumHash
+  -- ^ Hash of datum sent to effect validator with GAT
+  , scriptHash :: Maybe ScriptHash
+  -- ^ A 'ScriptHash' that encodes the authority script.
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    , -- | @since 1.0.0
+      Show
+    , -- | @since 1.0.0
+      Eq
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData ProposalEffectMetadata)
+
+-- | @since 1.0.0
+type ProposalEffectGroup = StrictMap.Map ScriptHash ProposalEffectMetadata
 
 {- | Haskell-level datum for Proposal scripts.
 
@@ -279,15 +328,17 @@ emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
 -}
 data ProposalDatum = ProposalDatum
   { proposalId :: ProposalId
-  -- ^ Identification of the proposal.
+  -- ^ Identification of the proposal. Note that this map should be sorted in
+  --    ascending order, and its keys should be unique.
+  --
   -- TODO: could we encode this more efficiently?
   -- This is shaped this way for future proofing.
   -- See https://github.com/Liqwid-Labs/agora/issues/39
-  , effects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  , effects :: StrictMap.Map ResultTag ProposalEffectGroup
   -- ^ Effect lookup table. First by result, then by effect hash.
   , status :: ProposalStatus
   -- ^ The status the proposal is in.
-  , cosigners :: [PubKeyHash]
+  , cosigners :: [Credential]
   -- ^ Who created the proposal initially, and who cosigned it later.
   --
   -- This list should be sorted in **ascending** order.
@@ -322,22 +373,20 @@ data ProposalDatum = ProposalDatum
 
 {- | Haskell-level redeemer for Proposal scripts.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 data ProposalRedeemer
   = -- | Cast one or more votes towards a particular 'ResultTag'.
     Vote ResultTag
-  | -- | Add one or more public keys to the cosignature list.
-    --   Must be signed by those cosigning.
+  | -- | Add a credential to the cosignature list.
+    --   Must be authorized by the stake owner.
     --
     --   This is particularly used in the 'Draft' 'ProposalStatus',
-    --   where matching 'Agora.Stake.Stake's can be called to advance the proposal,
-    --   provided enough GT is shared among them.
-    --
-    --   This list should be sorted in ascending order.
-    Cosign [PubKeyHash]
+    --   where matching 'Agora.Stake.Stake's can be witnessed to advance the
+    --   proposal, provided enough GT is shared among them.
+    Cosign
   | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
-    Unlock
+    UnlockStake
   | -- | Advance the proposal, performing the required checks for whether that is legal.
     --
     --   These are roughly the checks for each possible transition:
@@ -377,7 +426,7 @@ PlutusTx.makeIsDataIndexed
   ''ProposalRedeemer
   [ ('Vote, 0)
   , ('Cosign, 1)
-  , ('Unlock, 2)
+  , ('UnlockStake, 2)
   , ('AdvanceProposal, 3)
   ]
 
@@ -471,8 +520,8 @@ deriving via
 data PProposalStatus (s :: S)
   = -- | @since 0.2.0
     PDraft
-  | -- | @since 0.2.0
-    PVoting
+  | -- | @since 1.0.0
+    PVotingReady
   | -- | @since 0.2.0
     PLocked
   | -- | @since 0.2.0
@@ -509,16 +558,18 @@ deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (P
 
 {- | Plutarch-level version of 'ProposalThresholds'.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 newtype PProposalThresholds (s :: S) = PProposalThresholds
   { getProposalThresholds ::
       Term
         s
         ( PDataRecord
-            '[ "execute" ':= PDiscrete GTTag
-             , "create" ':= PDiscrete GTTag
-             , "vote" ':= PDiscrete GTTag
+            '[ "execute" ':= PTagged GTTag PInteger
+             , "create" ':= PTagged GTTag PInteger
+             , "toVoting" ':= PTagged GTTag PInteger
+             , "vote" ':= PTagged GTTag PInteger
+             , "cosign" ':= PTagged GTTag PInteger
              ]
         )
   }
@@ -533,30 +584,39 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
       PIsData
     , -- | @since 0.1.0
       PDataFields
+    , -- | @since 0.2.1
+      PShow
     )
 
 -- | @since 0.2.0
 instance DerivePlutusType PProposalThresholds where
-  type DPTStrat _ = PlutusTypeData
+  type DPTStrat _ = PlutusTypeNewtype
 
 -- | @since 0.1.0
-instance PTryFrom PData PProposalThresholds
+instance PTryFrom PData (PAsData PProposalThresholds)
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaData ProposalThresholds PProposalThresholds)
+  (DerivePConstantViaDataList ProposalThresholds PProposalThresholds)
   instance
     (PConstantDecl ProposalThresholds)
 
 {- | Plutarch-level version of 'ProposalVotes'.
 
+     Note: we don't really need this map to be ordered on chain, the purpose of
+     tagging it as sorted is to ensure the uniqueness of the keys. This
+     introduces some performance overhead cause sortness is unnecessarily
+     checked every time we try to recover a `PPropopsalVotes` from `PData`.
+
+     FIXME(Connor): optimize away this.
+
      @since 0.1.0
 -}
 newtype PProposalVotes (s :: S)
-  = PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
+  = PProposalVotes (Term s (PMap 'Sorted PResultTag PInteger))
   deriving stock
     ( -- | @since 0.2.0
       Generic
@@ -566,6 +626,8 @@ newtype PProposalVotes (s :: S)
       PlutusType
     , -- | @since 0.1.0
       PIsData
+    , -- | @since 1.0.0
+      PShow
     )
 
 -- | @since 0.2.0
@@ -580,10 +642,67 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
+  (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Sorted PResultTag PInteger))
   instance
     (PConstantDecl ProposalVotes)
 
+{- | Plutarch-level version of 'ProposalEffectMetadata'.
+
+     @since 1.0.0
+-}
+newtype PProposalEffectMetadata (s :: S)
+  = PProposalEffectMetadata
+      ( Term
+          s
+          ( PDataRecord
+              '[ "datumHash" ':= PDatumHash
+               , "scriptHash" ':= PMaybeData (PAsData PScriptHash)
+               ]
+          )
+      )
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    , -- | @since 1.0.0
+      PIsData
+    , -- | @since 1.0.0
+      PEq
+    , -- | @since 1.0.0
+      PDataFields
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PProposalEffectMetadata where
+  type DPTStrat _ = PlutusTypeDataList
+
+-- | @since 1.0.0
+instance PUnsafeLiftDecl PProposalEffectMetadata where
+  type PLifted _ = ProposalEffectMetadata
+
+-- | @since 1.0.0
+deriving via
+  (DerivePConstantViaDataList ProposalEffectMetadata PProposalEffectMetadata)
+  instance
+    (PConstantDecl ProposalEffectMetadata)
+
+-- | @since 1.0.0
+instance PTryFrom PData (PAsData PProposalEffectMetadata)
+
+{- | The effect script hashes and their associated datum hash and authority check script hash
+     belonging to a particular effect group or result.
+
+     @since 1.0.0
+-}
+type PProposalEffectGroup =
+  PMap
+    'Sorted
+    PScriptHash
+    PProposalEffectMetadata
+
 {- | Plutarch-level version of 'ProposalDatum'.
 
      @since 0.1.0
@@ -594,9 +713,9 @@ newtype PProposalDatum (s :: S) = PProposalDatum
         s
         ( PDataRecord
             '[ "proposalId" ':= PProposalId
-             , "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+             , "effects" ':= PMap 'Sorted PResultTag PProposalEffectGroup
              , "status" ':= PProposalStatus
-             , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
+             , "cosigners" ':= PBuiltinList (PAsData PCredential)
              , "thresholds" ':= PProposalThresholds
              , "votes" ':= PProposalVotes
              , "timingConfig" ':= PProposalTimingConfig
@@ -615,16 +734,18 @@ newtype PProposalDatum (s :: S) = PProposalDatum
       PIsData
     , -- | @since 0.1.0
       PEq
+    , -- | @since 1.0.0
+      PDataFields
     )
 
--- | @since 0.2.0
+-- | @since 1.0.0
 instance DerivePlutusType PProposalDatum where
-  type DPTStrat _ = PlutusTypeNewtype
+  type DPTStrat _ = PlutusTypeDataList
 
 instance PTryFrom PData (PAsData PProposalDatum)
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
+instance PUnsafeLiftDecl PProposalDatum where type PLifted _ = ProposalDatum
 
 -- | @since 0.1.0
 deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
@@ -635,8 +756,8 @@ deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance
 -}
 data PProposalRedeemer (s :: S)
   = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
-  | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
-  | PUnlock (Term s (PDataRecord '[]))
+  | PCosign (Term s (PDataRecord '[]))
+  | PUnlockStake (Term s (PDataRecord '[]))
   | PAdvanceProposal (Term s (PDataRecord '[]))
   deriving stock
     ( -- | @since 0.1.0
@@ -679,7 +800,7 @@ phasNeutralEffect ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Sorted PResultTag PProposalEffectGroup
         :--> PBool
     )
 phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull
@@ -692,15 +813,15 @@ pisEffectsVotesCompatible ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Sorted PResultTag PProposalEffectGroup
         :--> PProposalVotes
         :--> PBool
     )
 pisEffectsVotesCompatible = phoistAcyclic $
-  plam $ \m (pto -> v :: Term _ (PMap _ _ _)) ->
-    PUM.pkeysEqual # m # v
+  plam $ \((PM.pkeys @PList #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) ->
+    plistEquals # effectKeys # voteKeys
 
-{- | Retutns true if vote counts of /all/ the options are zero.
+{- | Returns true if vote counts of /all/ the options are zero.
 
    @since 0.2.0
 -}
@@ -721,6 +842,7 @@ pisVotesEmpty = phoistAcyclic $
      @since 0.1.0
 -}
 pwinner ::
+  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -741,6 +863,7 @@ pwinner = phoistAcyclic $
      @since 0.1.0
 -}
 pwinner' ::
+  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -774,8 +897,8 @@ pwinner' = phoistAcyclic $
             pfoldr # f # 0 # l #== 1
 
         exceedQuorum =
-          ptraceIfFalse "Highest vote count should exceed the minimum threshold" $
-            quorum #< highestVotes
+          ptraceIfFalse "Highest vote count should be at least the minimum threshold" $
+            quorum #<= highestVotes
 
     pure $
       pif
@@ -788,6 +911,7 @@ pwinner' = phoistAcyclic $
      @since 0.1.0
 -}
 phighestVotes ::
+  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -810,9 +934,10 @@ phighestVotes = phoistAcyclic $
      @since 0.1.0
 -}
 pneutralOption ::
+  forall (s :: S).
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Sorted PResultTag PProposalEffectGroup
         :--> PResultTag
     )
 pneutralOption = phoistAcyclic $
@@ -827,7 +952,7 @@ pneutralOption = phoistAcyclic $
                 (PAssocMap.pnull # el)
                 (pcon $ PJust rt)
                 (pcon PNothing)
-     in pfromJust #$ pfirstJust # f # l
+     in pfromJust #$ pfindJust # f # l
 
 {- | Return true if the thresholds are valid.
 
@@ -835,33 +960,30 @@ pneutralOption = phoistAcyclic $
 -}
 pisProposalThresholdsValid :: forall (s :: S). Term s (PProposalThresholds :--> PBool)
 pisProposalThresholdsValid = phoistAcyclic $
-  plam $ \thresholds -> unTermCont $ do
-    thresholdsF <- pletAllC thresholds
-
-    PDiscrete execute' <- pmatchC thresholdsF.execute
-    PDiscrete draft' <- pmatchC thresholdsF.create
-    PDiscrete vote' <- pmatchC thresholdsF.vote
-
-    execute <- pletC $ pextract # execute'
-    draft <- pletC $ pextract # draft'
-    vote <- pletC $ pextract # vote'
-
-    pure $
+  plam $
+    flip pletAll $ \thresholdsF ->
       foldr1
         (#&&)
-        [ ptraceIfFalse "Execute threshold is less than or equal to 0" $ 0 #<= execute
-        , ptraceIfFalse "Draft threshold is less than or equal to 0" $ 0 #<= draft
-        , ptraceIfFalse "Vote threshold is less than or equal to 0" $ 0 #<= vote
+        [ ptraceIfFalse "Execute threshold is less than or equal to 0" $
+            0 #<= pfromData thresholdsF.execute
+        , ptraceIfFalse "Create threshold is less than or equal to 0" $
+            0 #<= pfromData thresholdsF.create
+        , ptraceIfFalse "toVoting threshold is less than or equal to 0" $
+            0 #<= pfromData thresholdsF.toVoting
+        , ptraceIfFalse "Vote threshold is less than or equal to 0" $
+            0 #<= pfromData thresholdsF.vote
+        , ptraceIfFalse "Cosign threshold is less than or equal to 0" $
+            0 #<= pfromData thresholdsF.cosign
         ]
 
 {- | Retract votes given the option and the amount of votes.
 
      @since 0.1.0
 -}
-pretractVotes :: Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
+pretractVotes :: forall (s :: S). Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
 pretractVotes = phoistAcyclic $
   plam $ \rt count votes ->
-    let voteMap :: Term _ (PMap 'Unsorted PResultTag PInteger)
+    let voteMap :: Term _ (PMap 'Sorted PResultTag PInteger)
         voteMap = pto votes
      in pcon $
           PProposalVotes $

agora/Agora/Proposal/Time.hs

@@ -14,47 +14,59 @@ module Agora.Proposal.Time (
   MaxTimeRangeWidth (..),
 
   -- * Plutarch-land
-  PProposalTime (..),
+  PProposalTime,
   PProposalTimingConfig (..),
   PProposalStartingTime (..),
   PMaxTimeRangeWidth (..),
+  PTimingRelation (..),
+  PPeriod (..),
 
   -- * Compute periods given config and starting time.
-  createProposalStartingTime,
-  currentProposalTime,
-  isDraftPeriod,
-  isVotingPeriod,
-  isLockingPeriod,
-  isExecutionPeriod,
+  pvalidateProposalStartingTime,
+  pcurrentProposalTime,
   pisProposalTimingConfigValid,
   pisMaxTimeRangeWidthValid,
+  pgetRelation,
+  pisWithin,
+  psatisfyMaximumWidth,
 ) where
 
-import Control.Composition ((.*))
+import Data.Functor ((<&>))
+import Generics.SOP qualified as SOP
 import Plutarch.Api.V1 (
   PExtended (PFinite),
   PInterval (PInterval),
   PLowerBound (PLowerBound),
   PPOSIXTime,
-  PPOSIXTimeRange,
   PUpperBound (PUpperBound),
  )
+import Plutarch.Api.V2 (PPOSIXTimeRange)
 import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
   PDataFields,
  )
 import Plutarch.Extra.Applicative (PApply (pliftA2))
+import Plutarch.Extra.Bool (passert)
 import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
-import Plutarch.Extra.TermCont (pmatchC)
-import Plutarch.Lift (
-  DerivePConstantViaNewtype (..),
-  PConstantDecl,
-  PUnsafeLiftDecl (..),
+import Plutarch.Extra.IsData (
+  DerivePConstantViaDataList (DerivePConstantViaDataList),
+  PlutusTypeEnumData,
+  ProductIsData (ProductIsData),
  )
+import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
+import Plutarch.Extra.Time (
+  PFullyBoundedTimeRange (PFullyBoundedTimeRange),
+  pisWithinTimeRange,
+  ptimeRangeDuration,
+ )
+import Plutarch.Lift (
+  DerivePConstantViaNewtype (DerivePConstantViaNewtype),
+  PConstantDecl,
+  PUnsafeLiftDecl (PLifted),
+ )
+import Plutarch.Num (PNum)
 import PlutusLedgerApi.V1 (POSIXTime)
 import PlutusTx qualified
-import Prelude
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
 
 --------------------------------------------------------------------------------
 
@@ -78,37 +90,8 @@ newtype ProposalStartingTime = ProposalStartingTime
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
-    , -- | @since 0.1.0
-      PlutusTx.UnsafeFromData
     )
 
-{- | Configuration of proposal timings.
-
-     See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
-
-     @since 0.1.0
--}
-data ProposalTimingConfig = ProposalTimingConfig
-  { draftTime :: POSIXTime
-  -- ^ "D": the length of the draft period.
-  , votingTime :: POSIXTime
-  -- ^ "V": the length of the voting period.
-  , lockingTime :: POSIXTime
-  -- ^ "L": the length of the locking period.
-  , executingTime :: POSIXTime
-  -- ^ "E": the length of the execution period.
-  }
-  deriving stock
-    ( -- | @since 0.1.0
-      Eq
-    , -- | @since 0.1.0
-      Show
-    , -- | @since 0.1.0
-      Generic
-    )
-
-PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
-
 -- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
 newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
   deriving stock
@@ -126,10 +109,50 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
-    , -- | @since 0.1.0
-      PlutusTx.UnsafeFromData
+    , -- | @since 1.0.0
+      Num
     )
 
+{- | Configuration of proposal timings.
+
+     See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
+
+     @since 0.1.0
+-}
+data ProposalTimingConfig = ProposalTimingConfig
+  { draftTime :: POSIXTime
+  -- ^ "D": the length of the draft period.
+  , votingTime :: POSIXTime
+  -- ^ "V": the length of the voting period.
+  , lockingTime :: POSIXTime
+  -- ^ "L": the length of the locking period.
+  , executingTime :: POSIXTime
+  -- ^ "E": the length of the execution period.
+  , minStakeVotingTime :: POSIXTime
+  -- ^ Minimum time from creating a voting lock until it can be destroyed.
+  , votingTimeRangeMaxWidth :: MaxTimeRangeWidth
+  -- ^ The maximum width of transaction time range while voting.
+  }
+  deriving stock
+    ( -- | @since 0.1.0
+      Eq
+    , -- | @since 0.1.0
+      Show
+    , -- | @since 0.1.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 1.0.0
+      PlutusTx.ToData
+    , -- | @since 1.0.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData ProposalTimingConfig)
+
 --------------------------------------------------------------------------------
 
 {- | == Establishing timing in Proposal interactions.
@@ -159,23 +182,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
 
      @since 0.1.0
 -}
-data PProposalTime (s :: S) = PProposalTime
-  { lowerBound :: Term s PPOSIXTime
-  , upperBound :: Term s PPOSIXTime
-  }
-  deriving stock
-    ( -- | @since 0.1.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 0.1.0
-      PlutusType
-    , -- | @since 0.1.0
-      PEq
-    )
-
-instance DerivePlutusType PProposalTime where
-  type DPTStrat _ = PlutusTypeScott
+type PProposalTime = PFullyBoundedTimeRange
 
 -- | Plutarch-level version of 'ProposalStartingTime'.
 newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@@ -220,6 +227,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
              , "votingTime" ':= PPOSIXTime
              , "lockingTime" ':= PPOSIXTime
              , "executingTime" ':= PPOSIXTime
+             , "minStakeVotingTime" ':= PPOSIXTime
+             , "votingTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
              ]
         )
   }
@@ -234,13 +243,15 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
       PIsData
     , -- | @since 0.1.0
       PDataFields
+    , -- | @since 0.2.1
+      PShow
     )
 
 instance DerivePlutusType PProposalTimingConfig where
-  type DPTStrat _ = PlutusTypeData
+  type DPTStrat _ = PlutusTypeNewtype
 
 -- | @since 0.1.0
-instance PTryFrom PData PProposalTimingConfig
+instance PTryFrom PData (PAsData PProposalTimingConfig)
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PProposalTimingConfig where
@@ -248,7 +259,7 @@ instance PUnsafeLiftDecl PProposalTimingConfig where
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
+  (DerivePConstantViaDataList ProposalTimingConfig PProposalTimingConfig)
   instance
     (PConstantDecl ProposalTimingConfig)
 
@@ -270,6 +281,10 @@ newtype PMaxTimeRangeWidth (s :: S)
       PPartialOrd
     , -- | @since 0.1.0
       POrd
+    , -- | @since 0.2.1
+      PShow
+    , -- | @since 1.0.0
+      PNum
     )
 
 instance DerivePlutusType PMaxTimeRangeWidth where
@@ -293,7 +308,7 @@ deriving via
 
      @since 0.2.0
 -}
-pisProposalTimingConfigValid :: Term s (PProposalTimingConfig :--> PBool)
+pisProposalTimingConfigValid :: forall (s :: S). Term s (PProposalTimingConfig :--> PBool)
 pisProposalTimingConfigValid = phoistAcyclic $
   plam $ \conf -> unTermCont $ do
     confF <- pletAllC conf
@@ -313,6 +328,8 @@ pisProposalTimingConfigValid = phoistAcyclic $
           , confF.votingTime
           , confF.lockingTime
           , confF.executingTime
+          , confF.minStakeVotingTime
+          , pto confF.votingTimeRangeMaxWidth
           ]
 
 {- | Return true if the maximum time width is greater than 0.
@@ -326,162 +343,203 @@ pisMaxTimeRangeWidthValid =
       ptraceIfFalse "greater than 0"
         . (pconstant (MaxTimeRangeWidth 0) #<)
 
-{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
+{- | Validate starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
      For every proposal, this is only meant to run once upon creation. Given time range should be
      tight enough, meaning that the width of the time range should be less than the maximum value.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
-createProposalStartingTime ::
+pvalidateProposalStartingTime ::
   forall (s :: S).
   Term
     s
     ( PMaxTimeRangeWidth
         :--> PPOSIXTimeRange
-        :--> PMaybe PProposalStartingTime
+        :--> PProposalStartingTime
+        :--> PBool
     )
-createProposalStartingTime = phoistAcyclic $
-  plam $ \(pto -> maxDuration) iv ->
-    let ct = currentProposalTime # iv
+pvalidateProposalStartingTime = phoistAcyclic $
+  plam $ \maxWidth iv (pto -> st) ->
+    pmaybe
+      # pconstant False
+      # plam
+        ( \ct ->
+            let isTightEnough =
+                  ptraceIfFalse
+                    "createProposalStartingTime: given time range should be tight enough"
+                    $ psatisfyMaximumWidth # maxWidth # ct
+                isInCurrentTimeRange =
+                  ptraceIfFalse
+                    "createProposalStartingTime: starting time should be in current time range"
+                    $ pisWithinTimeRange # st # ct
+             in isTightEnough #&& isInCurrentTimeRange
+        )
+      # (pcurrentProposalTime # iv)
 
-        f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime)
-        f = plam $
-          flip pmatch $ \(PProposalTime lb ub) ->
-            let duration = ub - lb
-
-                startingTime = pdiv # (lb + ub) # 2
-             in pif
-                  (duration #<= maxDuration)
-                  (pjust #$ pcon $ PProposalStartingTime startingTime)
-                  ( ptrace
-                      "createProposalStartingTime: given time range should be tight enough"
-                      pnothing
-                  )
-     in -- TODO: PMonad when?
-        pmaybe # pnothing # f # ct
-
-{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
+{- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
 
      If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
-     an infinity) then we error out.
+     an infinity) then we return nothing.
+
+     Note that we ignore the inclusiveness of the upper bound. Due to the fact
+      that there's no place in the Cardano domain transaction type to store the
+      inclusiveness information, we can never get a time range with closed upper
+      bound. See also the ledger implementation: https://bit.ly/3BDzW5R
 
      @since 0.1.0
 -}
-currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
-currentProposalTime = phoistAcyclic $
+pcurrentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
+pcurrentProposalTime = phoistAcyclic $
   plam $ \iv -> unTermCont $ do
     PInterval iv' <- pmatchC iv
     ivf <- pletAllC iv'
     PLowerBound lb <- pmatchC ivf.from
     PUpperBound ub <- pmatchC ivf.to
 
-    let getBound = phoistAcyclic $
-          plam $
-            flip pletAll $ \f ->
-              pif
-                f._1
-                ( pmatch f._0 $ \case
-                    PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
-                    _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
-                )
-                (ptrace "currentProposalTime: time range should be inclusive" pnothing)
+    let lowerBound = pletAll lb $ \f ->
+          pif
+            f._1
+            ( pmatch f._0 $ \case
+                PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
+                _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
+            )
+            (ptrace "currentProposalTime: lower bound of the time range should be inclusive" pnothing)
 
-        lowerBound = getBound # lb
-        upperBound = getBound # ub
+        upperBound = pletAll ub $ \f ->
+          pmatch f._0 $ \case
+            PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
+            _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
+
+        mkTime = phoistAcyclic $
+          plam $ \lb ub ->
+            passert
+              "Upper bound bigger than lower bound"
+              (lb #< ub)
+              (pcon $ PFullyBoundedTimeRange lb ub)
 
-        mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime
     pure $ pliftA2 # mkTime # lowerBound # upperBound
 
-{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
+{- | Represent relation between current time and a given period.
 
-     @since 0.1.0
+     Note that the "before" relation isn't present due to the fact that
+     it's considered as an error in the proposal script.
+
+     @since 1.0.0
 -}
-proposalTimeWithin ::
+data PTimingRelation (s :: S)
+  = PWithin
+  | PAfter
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    , -- | @since 1.0.0
+      Enum
+    , -- | @since 1.0.0
+      Bounded
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PTimingRelation where
+  type DPTStrat _ = PlutusTypeEnumData
+
+{- | Return true if a relation is 'PWithin'.
+
+     @since 1.0.0
+-}
+pisWithin :: forall (s :: S). Term s (PTimingRelation :--> PBool)
+pisWithin = phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PWithin -> pconstant True
+      _ -> pconstant False
+
+{- | Represent a proposal period.
+
+     @since 1.0.0
+-}
+data PPeriod (s :: S)
+  = PDraftingPeriod
+  | PVotingPeriod
+  | PLockingPeriod
+  | PExecutingPeriod
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    , -- | @since 1.0.0
+      Enum
+    , -- | @since 1.0.0
+      Bounded
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PPeriod where
+  type DPTStrat _ = PlutusTypeEnumData
+
+{- | Compute the relation between current time range and the given peroid,
+     providing the starting time and timing configuration of a proposal. If the
+     relation cannot be determined, error out.
+
+     @since 1.0.0
+-}
+pgetRelation ::
+  forall (s :: S).
   Term
     s
-    ( PPOSIXTime
-        :--> PPOSIXTime
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
         :--> PProposalTime
-        :--> PBool
+        :--> PPeriod
+        :--> PTimingRelation
     )
-proposalTimeWithin = phoistAcyclic $
-  plam $ \l h proposalTime' -> unTermCont $ do
-    PProposalTime ut lt <- pmatchC proposalTime'
+pgetRelation = phoistAcyclic $
+  plam $ \config startingTime currentTime period -> unTermCont $ do
+    configF <- pletAllC config
+
+    PProposalStartingTime s <- pmatchC startingTime
+    PFullyBoundedTimeRange lb ub <- pmatchC currentTime
+
+    dub <- pletC $ s + configF.draftTime
+    vub <- pletC $ dub + configF.votingTime
+    lub <- pletC $ vub + configF.lockingTime
+    eub <- pletC $ lub + configF.executingTime
+
+    (plb, pub) <-
+      pmatchC period
+        <&> ( \case
+                PDraftingPeriod -> (s, dub)
+                PVotingPeriod -> (dub, vub)
+                PLockingPeriod -> (vub, lub)
+                PExecutingPeriod -> (lub, eub)
+            )
+
     pure $
-      foldr1
-        (#&&)
-        [ l #<= lt
-        , ut #<= h
-        ]
+      pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
+        pif (pub #< lb) (pcon PAfter) $
+          ptraceError "pgetRelation: too early or invalid current time"
 
-{- | True if the 'PProposalTime' is in the draft period.
+{- | Return true if the width of given 'PProposalTime' is shorter than the
+     maximum.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
-isDraftPeriod ::
+psatisfyMaximumWidth ::
   forall (s :: S).
   Term
     s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
+    ( PMaxTimeRangeWidth
         :--> PProposalTime
         :--> PBool
     )
-isDraftPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    proposalTimeWithin # s # (s + (pfield @"draftTime" # config))
-
-{- | True if the 'PProposalTime' is in the voting period.
-
-     @since 0.1.0
--}
-isVotingPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isVotingPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime"] config $ \f ->
-      proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
-
-{- | True if the 'PProposalTime' is in the locking period.
-
-     @since 0.1.0
--}
-isLockingPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isLockingPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
-      proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
-
-{- | True if the 'PProposalTime' is in the execution period.
-
-     @since 0.1.0
--}
-isExecutionPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isExecutionPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
-      proposalTimeWithin # s
-        # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
+psatisfyMaximumWidth = phoistAcyclic $
+  plam $ \maxWidth time ->
+    let width = ptimeRangeDuration # time
+        max = pto maxWidth
+     in width #<= max

agora/Agora/SafeMoney.hs

@@ -11,6 +11,7 @@ module Agora.SafeMoney (
   GovernorSTTag,
   StakeSTTag,
   ProposalSTTag,
+  AuthorityTokenTag,
   adaRef,
 ) where
 
@@ -21,31 +22,37 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
 
      @since 0.1.0
 -}
-data GTTag
+type GTTag = "GTTag"
 
 {- | ADA.
 
      @since 0.1.0
 -}
-data ADATag
+type ADATag = "ADATag"
 
 {- | Governor ST token.
 
      @since 0.1.0
 -}
-data GovernorSTTag
+type GovernorSTTag = "GovernorSTTag"
 
 {- | Stake ST token.
 
      @since 0.1.0
 -}
-data StakeSTTag
+type StakeSTTag = "StakeSTTag"
 
 {- | Proposal ST token.
 
      @since 0.1.0
 -}
-data ProposalSTTag
+type ProposalSTTag = "ProposalSTTag"
+
+{- | Authority token.
+
+     @since 1.0.0
+-}
+type AuthorityTokenTag = "AuthorityTokenTag"
 
 {- | Resolves ada tags.
 

agora/Agora/Scripts.hs

@@ -1,138 +0,0 @@
-{- | Module     : Agora.Scripts
-     Maintainer : connor@mlabs.city
-     Description: Precompiled core scripts and utilities
-
-     Precompiled core scripts and utilities
--}
-module Agora.Scripts (
-  AgoraScripts (..),
-  governorSTSymbol,
-  governorSTAssetClass,
-  governorValidatorHash,
-  proposalSTSymbol,
-  proposalSTAssetClass,
-  proposalValidatoHash,
-  stakeSTSymbol,
-  stakeSTAssetClass,
-  stakeValidatorHash,
-  authorityTokenSymbol,
-  treasuryValidatorHash,
-) where
-
-import Agora.Governor (GovernorDatum, GovernorRedeemer)
-import Agora.Proposal (ProposalDatum, ProposalRedeemer)
-import Agora.Stake (StakeDatum, StakeRedeemer)
-import Agora.Treasury (TreasuryRedeemer)
-import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..), validatorHashToTokenName)
-import Plutarch.Api.V1 (mintingPolicySymbol, validatorHash)
-import PlutusLedgerApi.V1 (CurrencySymbol)
-import PlutusLedgerApi.V1.Scripts (ValidatorHash)
-import PlutusLedgerApi.V1.Value (AssetClass (..))
-
-{- | Precompiled core scripts.
-
-     Including:
-
-    - Governor policy
-    - Governor validator
-    - Proposal policy
-    - Proposal validator
-    - Stake policy
-    - Stake validator
-    - Treasury validator
-    - Authority token policy
-
-     @since 0.2.0
--}
-data AgoraScripts = AgoraScripts
-  { compiledGovernorPolicy :: CompiledMintingPolicy ()
-  , compiledGovernorValidator :: CompiledValidator GovernorDatum GovernorRedeemer
-  , compiledStakePolicy :: CompiledMintingPolicy ()
-  , compiledStakeValidator :: CompiledValidator StakeDatum StakeRedeemer
-  , compiledProposalPolicy :: CompiledMintingPolicy ()
-  , compiledProposalValidator :: CompiledValidator ProposalDatum ProposalRedeemer
-  , compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
-  , compiledAuthorityTokenPolicy :: CompiledMintingPolicy ()
-  }
-
-{- | Get the currency symbol of the governor state token.
-
-     @since 0.2.0
--}
-governorSTSymbol :: AgoraScripts -> CurrencySymbol
-governorSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledGovernorPolicy
-
-{- | Get the asset class of the governor state token.
-
-     @since 0.2.0
--}
-governorSTAssetClass :: AgoraScripts -> AssetClass
-governorSTAssetClass as = AssetClass (governorSTSymbol as, "")
-
-{- | Get the script hash of the governor validator.
-
-     @since 0.2.0
--}
-governorValidatorHash :: AgoraScripts -> ValidatorHash
-governorValidatorHash = validatorHash . getCompiledValidator . compiledGovernorValidator
-
-{- | Get the currency symbol of the propsoal state token.
-
-     @since 0.2.0
--}
-proposalSTSymbol :: AgoraScripts -> CurrencySymbol
-proposalSTSymbol as = mintingPolicySymbol $ getCompiledMintingPolicy as.compiledProposalPolicy
-
-{- | Get the asset class of the governor state token.
-
-     @since 0.2.0
--}
-proposalSTAssetClass :: AgoraScripts -> AssetClass
-proposalSTAssetClass as = AssetClass (proposalSTSymbol as, "")
-
-{- | Get the script hash of the proposal validator.
-
-     @since 0.2.0
--}
-proposalValidatoHash :: AgoraScripts -> ValidatorHash
-proposalValidatoHash = validatorHash . getCompiledValidator . compiledProposalValidator
-
-{- | Get the script hash of the governor validator.
-
-     @since 0.2.0
--}
-stakeSTSymbol :: AgoraScripts -> CurrencySymbol
-stakeSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledStakePolicy
-
-{- | Get the asset class of the stake state token.
-
-     Note that this token is tagged with the hash of the stake validator.
-      See 'Agora.Stake.Script.stakePolicy'.
-
-     @since 0.2.0
--}
-stakeSTAssetClass :: AgoraScripts -> AssetClass
-stakeSTAssetClass as =
-  let tn = validatorHashToTokenName $ stakeValidatorHash as
-   in AssetClass (stakeSTSymbol as, tn)
-
-{- | Get the script hash of the stake validator.
-
-     @since 0.2.0
--}
-stakeValidatorHash :: AgoraScripts -> ValidatorHash
-stakeValidatorHash = validatorHash . getCompiledValidator . compiledStakeValidator
-
-{- | Get the currency symbol of the authority token.
-
-     @since 0.2.0
--}
-authorityTokenSymbol :: AgoraScripts -> CurrencySymbol
-authorityTokenSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledAuthorityTokenPolicy
-
-{- | Get the script hash of the treasury validator.
-
-     @since 0.2.0
--}
-treasuryValidatorHash :: AgoraScripts -> ValidatorHash
-treasuryValidatorHash = validatorHash . getCompiledValidator . compiledTreasuryValidator

agora/Agora/Stake.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoFieldSelectors #-}
 
 {- |
 Module     : Agora.Stake
@@ -11,53 +12,119 @@ module Agora.Stake (
   -- * Haskell-land
   StakeDatum (..),
   StakeRedeemer (..),
+  ProposalAction (..),
   ProposalLock (..),
 
   -- * Plutarch-land
   PStakeDatum (..),
   PStakeRedeemer (..),
+  PProposalAction (..),
   PProposalLock (..),
   PStakeRole (..),
 
+  -- * Validation context
+  PSignedBy (..),
+  PSigContext (..),
+  PStakeRedeemerContext (..),
+  PStakeRedeemerHandlerContext (..),
+  PProposalContext (..),
+  PStakeRedeemerHandler,
+  StakeRedeemerImpl (..),
+
   -- * Utility functions
   pstakeLocked,
   pnumCreatedProposals,
   pextractVoteOption,
-  pgetStakeRole,
+  pgetStakeRoles,
   pisVoter,
   pisCreator,
-  pisPureCreator,
+  pisCosigner,
   pisIrrelevant,
+  presolveStakeInputDatum,
 ) where
 
-import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
-import Agora.SafeMoney (GTTag)
-import Data.Tagged (Tagged (..))
+import Agora.Proposal (
+  PProposalDatum,
+  PProposalId,
+  PProposalRedeemer,
+  PResultTag,
+  ProposalId,
+  ResultTag,
+ )
+import Agora.Proposal.Time (PProposalTime)
+import Agora.SafeMoney (GTTag, StakeSTTag)
+import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (
+import Plutarch.Api.V1 (PCredential, PPOSIXTime)
+import Plutarch.Api.V2 (
+  KeyGuarantees (Unsorted),
+  PDatum,
+  PDatumHash,
+  PMap,
   PMaybeData,
-  PPubKeyHash,
+  PTxInInfo,
+  PTxInfo,
  )
 import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
+  DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
  )
-import Plutarch.Extra.Field (pletAll)
+import Plutarch.Extra.Applicative (ppureIf)
+import Plutarch.Extra.AssetClass (PAssetClass)
 import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (..),
+  DerivePConstantViaDataList (DerivePConstantViaDataList),
   ProductIsData (ProductIsData),
  )
-import Plutarch.Extra.List (pnotNull)
-import Plutarch.Extra.Sum (PSum (..))
+import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
+import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
+import Plutarch.Extra.Sum (PSum (PSum))
+import Plutarch.Extra.Tagged (PTagged)
 import Plutarch.Extra.Traversable (pfoldMap)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
-import Plutarch.SafeMoney (PDiscrete)
-import Plutarch.Show (PShow (..))
-import PlutusLedgerApi.V1 (PubKeyHash)
+import Plutarch.Extra.Value (passetClassValueOfT)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import PlutusLedgerApi.V2 (Credential, POSIXTime)
 import PlutusTx qualified
-import Prelude hiding (Num (..))
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
 
 --------------------------------------------------------------------------------
 
+{- | The action that was performed on a particular proposal.
+
+     @since 1.0.0
+-}
+data ProposalAction
+  = -- | The stake was used to create a proposal.
+    --
+    --   This kind of lock is placed upon the creation of a proposal, in order
+    --    to limit creation of proposals per stake.
+    --
+    --   See also: https://github.com/Liqwid-Labs/agora/issues/68
+    Created
+  | -- | The stake was used to vote on a proposal.
+    --
+    --   This kind of lock is placed while voting on a proposal, in order to
+    --    prevent depositing and withdrawing when votes are in place.
+    Voted
+      ResultTag
+      -- ^ The option which was voted on. This allows votes to be retracted.
+      POSIXTime
+      -- ^ The upper bound of the transaction time range when the lock is created.
+  | -- | The stake was used to cosign a proposal.`
+    Cosigned
+  deriving stock
+    ( -- | @since 1.0.0
+      Show
+    , -- | @since 1.0.0
+      Generic
+    )
+
+PlutusTx.makeIsDataIndexed
+  ''ProposalAction
+  [ ('Created, 0)
+  , ('Voted, 1)
+  , ('Cosigned, 2)
+  ]
+
 {- | Locks that are stored in the stake datums for various purposes.
 
      NOTE: Due to retracting votes always being possible,
@@ -83,53 +150,41 @@ import Prelude hiding (Num (..))
      └──────────────┘      └─────────────────┘
      @
 
-     @since 0.1.0
+     @since 1.0.0
 -}
-data ProposalLock
-  = -- | The stake was used to create a proposal.
-    --
-    --   This kind of lock is placed upon the creation of a proposal, in order
-    --    to limit creation of proposals per stake.
-    --
-    --   See also: https://github.com/Liqwid-Labs/agora/issues/68
-    --
-    --   @since 0.2.0
-    Created
-      ProposalId
-      -- ^ The identifier of the proposal.
-  | -- | The stake was used to vote on a proposal.
-    --
-    --   This kind of lock is placed while voting on a proposal, in order to
-    --    prevent depositing and withdrawing when votes are in place.
-    --
-    --   @since 0.2.0
-    Voted
-      ProposalId
-      -- ^ The identifier of the proposal.
-      ResultTag
-      -- ^ The option which was voted on. This allows votes to be retracted.
+data ProposalLock = ProposalLock
+  { proposalId :: ProposalId
+  -- ^ The identifier of the proposal.
+  , action :: ProposalAction
+  -- ^ The action that has been performed.
+  }
   deriving stock
     ( -- | @since 0.1.0
       Show
     , -- | @since 0.1.0
       Generic
     )
-
-PlutusTx.makeIsDataIndexed
-  ''ProposalLock
-  [ ('Created, 0)
-  , ('Voted, 1)
-  ]
+  deriving anyclass
+    ( -- | @since 0.1.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 0.1.0
+      PlutusTx.ToData
+    , -- | @since 0.1.0
+      PlutusTx.FromData
+    )
+    via (ProductIsData ProposalLock)
 
 {- | Haskell-level redeemer for Stake scripts.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 data StakeRedeemer
   = -- | Deposit or withdraw a discrete amount of the staked governance token.
     --   Stake must be unlocked.
     DepositWithdraw (Tagged GTTag Integer)
-  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
+  | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
     --   Stake must be unlocked.
     Destroy
   | -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
@@ -143,12 +198,9 @@ data StakeRedeemer
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes
-  | -- | The owner can consume stake if nothing is changed about it.
-    --   If the proposal token moves, this is equivalent to the owner consuming it.
-    WitnessStake
   | -- | The owner can delegate the stake to another user, allowing the
     --    delegate to vote on prooposals with the stake.
-    DelegateTo PubKeyHash
+    DelegateTo Credential
   | -- | Revoke the existing delegation.
     ClearDelegate
   deriving stock
@@ -164,9 +216,8 @@ PlutusTx.makeIsDataIndexed
   , ('Destroy, 1)
   , ('PermitVote, 2)
   , ('RetractVotes, 3)
-  , ('WitnessStake, 4)
-  , ('DelegateTo, 5)
-  , ('ClearDelegate, 6)
+  , ('DelegateTo, 4)
+  , ('ClearDelegate, 5)
   ]
 
 {- | Haskell-level datum for Stake scripts.
@@ -177,12 +228,12 @@ data StakeDatum = StakeDatum
   { stakedAmount :: Tagged GTTag Integer
   -- ^ Tracks the amount of governance token staked in the datum.
   --   This also acts as the voting weight for 'Agora.Proposal.Proposal's.
-  , owner :: PubKeyHash
+  , owner :: Credential
   -- ^ The hash of the public key this stake belongs to.
   --
   -- TODO Support for MultiSig/Scripts is tracked here:
   --      https://github.com/Liqwid-Labs/agora/issues/45
-  , delegatedTo :: Maybe PubKeyHash
+  , delegatedTo :: Maybe Credential
   -- ^ To whom this stake has been delegated.
   , lockedBy :: [ProposalLock]
   -- ^ The current proposals locking this stake. This field must be empty
@@ -217,9 +268,9 @@ newtype PStakeDatum (s :: S) = PStakeDatum
       Term
         s
         ( PDataRecord
-            '[ "stakedAmount" ':= PDiscrete GTTag
-             , "owner" ':= PPubKeyHash
-             , "delegatedTo" ':= PMaybeData (PAsData PPubKeyHash)
+            '[ "stakedAmount" ':= PTagged GTTag PInteger
+             , "owner" ':= PCredential
+             , "delegatedTo" ':= PMaybeData (PAsData PCredential)
              , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
              ]
         )
@@ -235,37 +286,41 @@ newtype PStakeDatum (s :: S) = PStakeDatum
       PIsData
     , -- | @since 0.1.0
       PEq
+    , -- | @since 1.0.0
+      PDataFields
+    , -- | @since 1.0.0
+      PShow
     )
 
+-- | @since 1.0.0
 instance DerivePlutusType PStakeDatum where
   type DPTStrat _ = PlutusTypeNewtype
 
--- | @since 0.1.0
-instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
+-- | @since 1.0.0
+instance PUnsafeLiftDecl PStakeDatum where
   type PLifted PStakeDatum = StakeDatum
 
 -- | @since 0.1.0
 deriving via
   (DerivePConstantViaDataList StakeDatum PStakeDatum)
   instance
-    (Plutarch.Lift.PConstantDecl StakeDatum)
+    (PConstantDecl StakeDatum)
 
 -- | @since 0.1.0
 instance PTryFrom PData (PAsData PStakeDatum)
 
 {- | Plutarch-level redeemer for Stake scripts.
 
-     @since 0.1.0
+     @since 1.0.0
 -}
 data PStakeRedeemer (s :: S)
   = -- | Deposit or withdraw a discrete amount of the staked governance token.
-    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
-  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
+    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PTagged GTTag PInteger]))
+  | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '[]))
   | PRetractVotes (Term s (PDataRecord '[]))
-  | PWitnessStake (Term s (PDataRecord '[]))
-  | PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
+  | PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
   | PClearDelegate (Term s (PDataRecord '[]))
   deriving stock
     ( -- | @since 0.1.0
@@ -273,13 +328,12 @@ data PStakeRedeemer (s :: S)
     )
   deriving anyclass
     ( -- | @since 0.1.0
-      SOP.Generic
-    , -- | @since 0.1.0
       PlutusType
     , -- | @since 0.1.0
       PIsData
     )
 
+-- | @since 0.2.0
 instance DerivePlutusType PStakeRedeemer where
   type DPTStrat _ = PlutusTypeData
 
@@ -287,33 +341,74 @@ instance DerivePlutusType PStakeRedeemer where
 instance PTryFrom PData PStakeRedeemer
 
 -- | @since 0.1.0
-instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
+instance PUnsafeLiftDecl PStakeRedeemer where
   type PLifted PStakeRedeemer = StakeRedeemer
 
 -- | @since 0.1.0
 deriving via
   (DerivePConstantViaData StakeRedeemer PStakeRedeemer)
   instance
-    (Plutarch.Lift.PConstantDecl StakeRedeemer)
+    (PConstantDecl StakeRedeemer)
 
-{- | Plutarch-level version of 'ProposalLock'.
+{- | Plutarch-level version of 'ProposalAction'.
 
-     @since 0.2.0
+    @since 1.0.0
 -}
-data PProposalLock (s :: S)
-  = PCreated
-      ( Term
-          s
-          ( PDataRecord
-              '["created" ':= PProposalId]
-          )
-      )
+data PProposalAction (s :: S)
+  = PCreated (Term s (PDataRecord '[]))
   | PVoted
       ( Term
           s
           ( PDataRecord
-              '[ "votedOn" ':= PProposalId
-               , "votedFor" ':= PResultTag
+              '[ "votedFor" ':= PResultTag
+               , "createdAt" ':= PPOSIXTime
+               ]
+          )
+      )
+  | PCosigned (Term s (PDataRecord '[]))
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    , -- | @since 1.0.0
+      PIsData
+    , -- | @since 1.0.0
+      PEq
+    , -- | @since 1.0.0
+      PShow
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PProposalAction where
+  type DPTStrat _ = PlutusTypeData
+
+-- | @since 1.0.0
+instance PUnsafeLiftDecl PProposalAction where
+  type PLifted _ = ProposalAction
+
+-- | @since 1.0.0
+deriving via
+  (DerivePConstantViaData ProposalAction PProposalAction)
+  instance
+    (PConstantDecl ProposalAction)
+
+-- | @since 1.0.0
+instance PTryFrom PData PProposalAction
+
+{- | Plutarch-level version of 'ProposalLock'.
+
+     @since 1.0.0
+-}
+newtype PProposalLock (s :: S)
+  = PProposalLock
+      ( Term
+          s
+          ( PDataRecord
+              '[ "proposalId" ':= PProposalId
+               , "action" ':= PProposalAction
                ]
           )
       )
@@ -328,35 +423,28 @@ data PProposalLock (s :: S)
       PIsData
     , -- | @since 0.1.0
       PEq
+    , -- | @since 1.0.0
+      PDataFields
+    , -- | @since 0.2.0
+      PShow
     )
 
+-- | @since 0.2.0
 instance DerivePlutusType PProposalLock where
-  type DPTStrat _ = PlutusTypeData
-
--- | @since 0.1.0
-instance PTryFrom PData PProposalLock
+  type DPTStrat _ = PlutusTypeNewtype
 
 -- | @since 0.2.0
 instance PTryFrom PData (PAsData PProposalLock)
 
 -- | @since 0.1.0
-instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
+instance PUnsafeLiftDecl PProposalLock where
   type PLifted PProposalLock = ProposalLock
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaData ProposalLock PProposalLock)
+  (DerivePConstantViaDataList ProposalLock PProposalLock)
   instance
-    (Plutarch.Lift.PConstantDecl ProposalLock)
-
--- | @since 0.2.0
-instance PShow PProposalLock where
-  pshow' :: Bool -> Term s PProposalLock -> Term s PString
-  pshow' True x = "(" <> pshow' False x <> ")"
-  pshow' False lock = pmatch lock $ \case
-    PCreated ((pfield @"created" #) -> pid) -> "PCreated " <> pshow' True pid
-    PVoted x -> pletFields @'["votedOn", "votedFor"] x $ \xF ->
-      "PVoted " <> pshow' True xF.votedOn <> " " <> pshow' True xF.votedFor
+    (PConstantDecl ProposalLock)
 
 --------------------------------------------------------------------------------
 
@@ -367,28 +455,32 @@ instance PShow PProposalLock where
 pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
 pstakeLocked = phoistAcyclic $
   plam $ \stakeDatum ->
-    pnotNull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
+    pnot #$ pnull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
 
 {- | Get the number of *alive* proposals that were created by the given stake.
 
      @since 0.2.0
 -}
-pnumCreatedProposals :: Term s (PBuiltinList (PAsData PProposalLock) :--> PInteger)
+pnumCreatedProposals ::
+  forall (s :: S).
+  Term s (PBuiltinList (PAsData PProposalLock) :--> PInteger)
 pnumCreatedProposals =
   phoistAcyclic $
     plam $ \l ->
       pto $
         pfoldMap
           # plam
-            ( \(pfromData -> lock) -> pmatch lock $ \case
-                PCreated _ -> pcon $ PSum 1
-                _ -> mempty
+            ( \lock ->
+                let action = pfromData $ pfield @"action" # lock
+                 in pmatch action $ \case
+                      PCreated _ -> pcon $ PSum 1
+                      _ -> mempty
             )
           # l
 
 {- | The role of a stake for a particular proposal. Scott-encoded.
 
-     @since 0.2.0
+     @since 1.0.0
 -}
 data PStakeRole (s :: S)
   = -- | The stake was used to vote on the proposal.
@@ -397,122 +489,308 @@ data PStakeRole (s :: S)
       -- ^ The option which was voted for.
   | -- | The stake was used to create the proposal.
     PCreator
-  | -- | The stake was used to both create and vote on the proposal.
-    PBoth
-      (Term s PResultTag)
-      -- ^ The option which was voted for.
-  | -- | The stake has nothing to do with the given proposal.
-    PIrrelevant
+  | -- | The stake was used to cosign the propsoal.
+    PCosigner
   deriving stock
-    ( -- | @since 0.2.0
+    ( -- | @since 1.0.0
       Generic
     )
   deriving anyclass
-    ( -- | @since 0.2.0
+    ( -- | @since 1.0.0
       PlutusType
-    , -- | @since 0.2.0
-      PEq
     )
 
+-- | @since 1.0.0
 instance DerivePlutusType PStakeRole where
   type DPTStrat _ = PlutusTypeScott
 
-{- | Retutn true if the stake was used to voted on the proposal.
+-- | @since 1.0.0
+type PStakeRoles = PList PStakeRole
 
-     @since 0.2.0
+--------------------------------------------------------------------------------
+
+{- | Who authorizes the transaction?
+
+     @since 1.0.0
 -}
-pisVoter :: Term s (PStakeRole :--> PBool)
-pisVoter = phoistAcyclic $
-  plam $ \sr -> pmatch sr $ \case
-    PVoter _ -> pconstant True
-    PBoth _ -> pconstant True
-    _ -> pconstant False
+data PSignedBy (s :: S)
+  = -- | The stake owner authorized the transaction.
+    PSignedByOwner
+  | -- | The delegate authorized the transaction.
+    PSignedByDelegate
+  | -- | Both owner and delegate didn't authorize.
+    PUnknownSig
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
 
-{- | Retutn true if the stake was used to create the proposal.
+-- | @since 1.0.0
+instance DerivePlutusType PSignedBy where
+  type DPTStrat _ = PlutusTypeScott
 
-     @since 0.2.0
+{- | The signature context.
+
+     @since 1.0.0
 -}
-pisCreator :: Term s (PStakeRole :--> PBool)
-pisCreator = phoistAcyclic $
-  plam $ \sr -> pmatch sr $ \case
-    PCreator -> pconstant True
-    PBoth _ -> pconstant True
-    _ -> pconstant False
+data PSigContext (s :: S) = PSigContext
+  { owner :: Term s PCredential
+  , delegatee :: Term s (PMaybeData (PAsData PCredential))
+  , signedBy :: Term s PSignedBy
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
 
-{- | Retutn true if the stake was used to create the proposal, but not vote on
-     the proposal.
+-- | @since 1.0.0
+instance DerivePlutusType PSigContext where
+  type DPTStrat _ = PlutusTypeScott
 
-     @since 0.2.0
+{- | The metadata carried by the stake redeemer. See also 'StakeRedeemer'.
+
+     @since 1.0.0
 -}
-pisPureCreator :: Term s (PStakeRole :--> PBool)
-pisPureCreator = phoistAcyclic $
-  plam $ \sr -> pmatch sr $ \case
-    PCreator -> pconstant True
-    _ -> pconstant False
+data PStakeRedeemerContext (s :: S)
+  = -- | See also 'DepositWithdraw'.
+    PDepositWithdrawDelta (Term s (PTagged GTTag PInteger))
+  | -- | See also 'DelegateTo'.
+    PSetDelegateTo (Term s PCredential)
+  | PNoMetadata
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeRedeemerContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | The usage of proposal in the transaction.
+
+     @since 1.0.0
+-}
+data PProposalContext (s :: S)
+  = -- | A proposal is spent.
+    PSpendProposal
+      (Term s PProposalDatum)
+      (Term s PProposalRedeemer)
+      (Term s PProposalTime)
+  | -- | A new proposal is created.
+    PNewProposal
+      (Term s PProposalId)
+  | -- | No proposal is spent or created.
+    PNoProposal
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PProposalContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Context required in order for redeemer handlers to peform validation.
+
+     @1.0.0
+-}
+data PStakeRedeemerHandlerContext (s :: S) = PStakeRedeemerHandlerContext
+  { stakeInputDatums :: Term s (PList PStakeDatum)
+  , stakeOutputDatums :: Term s (PList PStakeDatum)
+  , redeemerContext :: Term s PStakeRedeemerContext
+  , sigContext :: Term s PSigContext
+  , proposalContext :: Term s PProposalContext
+  , extraTxContext :: Term s PTxInfo
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeRedeemerHandlerContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | The plutarch type signature of the redeemer handlers.
+
+     A redeemer handler is a piece of validation logic that performs a unique
+      set of checks for its corresponding stake redeemer.
+
+     @since 1.0.0
+-}
+type PStakeRedeemerHandler = PStakeRedeemerHandlerContext :--> PUnit
+
+{- | A collection of stake redeemer handlers for each stake redeemers.
+
+     @since 1.0.0
+-}
+data StakeRedeemerImpl (s :: S) = StakeRedeemerImpl
+  { onDepositWithdraw :: Term s PStakeRedeemerHandler
+  -- ^ Handler for 'DepositWithdraw'.
+  , onDestroy :: Term s PStakeRedeemerHandler
+  -- ^ Handler for 'Destroy'.
+  , onPermitVote :: Term s PStakeRedeemerHandler
+  -- ^ Handler for 'permitVotes'.
+  , onRetractVote :: Term s PStakeRedeemerHandler
+  -- ^ Handler for 'RetractVotes'.
+  , onDelegateTo :: Term s PStakeRedeemerHandler
+  -- ^ Handler for 'DelegateTo'.
+  , onClearDelegate :: Term s PStakeRedeemerHandler
+  -- ^ handler for 'ClearDelegate'.
+  }
+
+--------------------------------------------------------------------------------
+
+{- | Return true if the stake was used to voted on the proposal.
+
+     @since 1.0.0
+-}
+pisVoter :: forall (s :: S). Term s (PStakeRoles :--> PBool)
+pisVoter =
+  phoistAcyclic $
+    pany
+      #$ plam
+        ( \r -> pmatch r $ \case
+            PVoter _ -> pconstant True
+            _ -> pconstant False
+        )
+
+{- | Return true if the stake was used to create the proposal.
+
+     @since 1.0.0
+-}
+pisCreator :: forall (s :: S). Term s (PStakeRoles :--> PBool)
+pisCreator =
+  phoistAcyclic $
+    pany
+      #$ plam
+        ( \r -> pmatch r $ \case
+            PCreator -> pconstant True
+            _ -> pconstant False
+        )
+
+{- | Return true if the stake was used to cosign the proposal.
+
+     @since 1.0.0
+-}
+pisCosigner :: forall (s :: S). Term s (PStakeRoles :--> PBool)
+pisCosigner =
+  phoistAcyclic $
+    pany
+      #$ plam
+        ( \r -> pmatch r $ \case
+            PCosigner -> pconstant True
+            _ -> pconstant False
+        )
 
 {- | Return true if the stake isn't related to the proposal.
 
-     @since 0.2.0
+     @since 1.0.0
 -}
-pisIrrelevant :: Term s (PStakeRole :--> PBool)
-pisIrrelevant = phoistAcyclic $
-  plam $ \sr -> pmatch sr $ \case
-    PIrrelevant -> pconstant True
-    _ -> pconstant False
+pisIrrelevant :: forall (s :: S). Term s (PStakeRoles :--> PBool)
+pisIrrelevant = pnull
 
 {- | Get the role of a stake for the proposal specified by the poroposal id,
       given the 'StakeDatum.lockedBy' field of the stake.
 
-     Note that the list of locks is cosidered valid only if it contains at most
-      two locks from the given proposal: one voter lock and one creator lock.
-
-     @since 0.2.0
+     @since 1.0.0
 -}
-pgetStakeRole :: Term s (PProposalId :--> PBuiltinList (PAsData PProposalLock) :--> PStakeRole)
-pgetStakeRole = phoistAcyclic $
-  plam $ \pid locks ->
-    pfoldl
-      # plam
-        ( \role (pfromData -> lock) ->
-            let thisRole = pmatch lock $ \case
-                  PCreated ((pfield @"created" #) -> pid') ->
-                    pif
-                      (pid' #== pid)
-                      (pcon PCreator)
-                      (pcon PIrrelevant)
-                  PVoted lock' -> pletAll lock' $ \lockF ->
-                    pif
-                      (lockF.votedOn #== pid)
-                      (pcon $ PVoter lockF.votedFor)
-                      (pcon PIrrelevant)
-             in pcombineStakeRole # thisRole # role
-        )
-      # pcon PIrrelevant
-      # locks
-  where
-    pcombineStakeRole :: Term s (PStakeRole :--> PStakeRole :--> PStakeRole)
-    pcombineStakeRole = phoistAcyclic $
-      plam $ \x y ->
-        let cannotCombine = ptraceError "duplicate roles"
-         in pmatch x $ \case
-              PVoter r -> pmatch y $ \case
-                PCreator -> pcon $ PBoth r
-                PIrrelevant -> x
-                _ -> cannotCombine
-              PCreator -> pmatch y $ \case
-                PVoter r -> pcon $ PBoth r
-                PIrrelevant -> x
-                _ -> cannotCombine
-              PBoth _ -> cannotCombine
-              PIrrelevant -> y
+pgetStakeRoles ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalId
+        :--> PBuiltinList (PAsData PProposalLock)
+        :--> PStakeRoles
+    )
+pgetStakeRoles = phoistAcyclic $
+  plam $ \pid ->
+    let getStakeRole = flip (pletFields @'["proposalId", "action"]) $
+          \lockF ->
+            ppureIf
+              # (pid #== lockF.proposalId)
+              #$ pmatch lockF.action
+              $ \case
+                PCreated _ -> pcon PCreator
+                PVoted ((pfield @"votedFor" #) -> tag) ->
+                  pcon $ PVoter tag
+                PCosigned _ -> pcon PCosigner
+     in pmapMaybe # plam (getStakeRole . pfromData)
 
 {- | Get the outcome that was voted for.
 
-     @since 0.2.0
+     @since 1.0.0
 -}
-pextractVoteOption :: Term s (PStakeRole :--> PResultTag)
-pextractVoteOption = phoistAcyclic $
-  plam $ \sr -> pmatch sr $ \case
-    PVoter r -> r
-    PBoth r -> r
-    _ -> ptraceError "not voter"
+pextractVoteOption :: forall (s :: S). Term s (PStakeRoles :--> PResultTag)
+pextractVoteOption =
+  phoistAcyclic $
+    plam $
+      (passertPJust # "not voter" #)
+        . ( pfindJust
+              # plam
+                ( flip pmatch $ \case
+                    PVoter r -> pjust # r
+                    _ -> pnothing
+                )
+              #
+          )
+
+{- | Resolve stake datum, if the given `PTxInInfo` represents a stake input.
+     Return nothing otherwise.
+
+     The first parameter is the assetclass of SST.
+
+     @since 1.0.0
+-}
+presolveStakeInputDatum ::
+  forall (s :: S).
+  Term
+    s
+    ( PTagged StakeSTTag PAssetClass
+        :--> PMap 'Unsorted PDatumHash PDatum
+        :--> PTxInInfo
+        :--> PMaybe PStakeDatum
+    )
+presolveStakeInputDatum = phoistAcyclic $
+  plam $ \sstClass datums ->
+    flip
+      (pletFields @'["value", "datum", "address"])
+      ( \txOutF ->
+          let isStakeUTxO =
+                passetClassValueOfT
+                  # sstClass
+                  # txOutF.value
+                  #== 1
+
+              datum =
+                ptrace "Resolve stake datum" $
+                  pfromData $
+                    ptryFromOutputDatum @(PAsData PStakeDatum)
+                      # txOutF.datum
+                      # datums
+           in pif
+                isStakeUTxO
+                (pjust # datum)
+                pnothing
+      )
+      . (pfield @"resolved" #)

agora/Agora/Stake/Redeemers.hs

@@ -0,0 +1,500 @@
+{- |
+Module     : Agora.Stake.Redeemers
+Maintainer : connor@mlabs.city
+Description: Default implementation of stake redeemer handlers
+
+Default implementation of stake redeemer handlers.
+-}
+module Agora.Stake.Redeemers (
+  ppermitVote,
+  pretractVote,
+  pdelegateTo,
+  pclearDelegate,
+  pdestroy,
+  pdepositWithdraw,
+) where
+
+import Agora.Proposal (
+  PProposalId,
+  PProposalRedeemer (PCosign, PUnlockStake, PVote),
+  ProposalStatus (Finished),
+ )
+import Agora.Proposal.Time (PProposalTime)
+import Agora.Stake (
+  PProposalAction (PCosigned, PCreated, PVoted),
+  PProposalContext (
+    PNewProposal,
+    PNoProposal,
+    PSpendProposal
+  ),
+  PProposalLock (PProposalLock),
+  PSigContext (owner, signedBy),
+  PSignedBy (
+    PSignedByDelegate,
+    PSignedByOwner,
+    PUnknownSig
+  ),
+  PStakeDatum (PStakeDatum),
+  PStakeRedeemerContext (
+    PDepositWithdrawDelta,
+    PNoMetadata,
+    PSetDelegateTo
+  ),
+  PStakeRedeemerHandler,
+  PStakeRedeemerHandlerContext (
+    proposalContext,
+    redeemerContext,
+    sigContext,
+    stakeInputDatums,
+    stakeOutputDatums
+  ),
+  pstakeLocked,
+ )
+import Plutarch.Api.V1.Address (PCredential)
+import Plutarch.Api.V2 (PMaybeData, PPOSIXTime)
+import Plutarch.Extra.Bool (passert)
+import Plutarch.Extra.Field (pletAll, pletAllC)
+import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
+import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
+import Plutarch.Extra.Time (PFullyBoundedTimeRange (PFullyBoundedTimeRange))
+import "liqwid-plutarch-extra" Plutarch.Extra.List (
+  pisSingleton,
+  ptryDeleteFirstBy,
+  ptryFromSingleton,
+ )
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
+
+-- | A wrapper which ensures that no proposal is presented in the transaction.
+pwithoutProposal ::
+  forall (s :: S).
+  Term
+    s
+    (PStakeRedeemerHandler :--> PStakeRedeemerHandler)
+pwithoutProposal = phoistAcyclic $
+  plam $ \f ctx -> pmatch ctx $ \ctxF ->
+    pif
+      ( pmatch ctxF.proposalContext $ \case
+          PNoProposal -> pconstant True
+          _ -> pconstant False
+      )
+      (f # ctx)
+      (ptraceError "No proposal is allowed")
+
+{- | Validate stake outputs given a function that converts an input stake datum
+      to an ouput stake datum. / O(n^2) /.
+-}
+pbatchUpdateInputs ::
+  forall (s :: S).
+  Term
+    s
+    ( (PStakeDatum :--> PStakeDatum :--> PBool)
+        :--> PStakeRedeemerHandlerContext
+        :--> PBool
+    )
+pbatchUpdateInputs = phoistAcyclic $
+  plam $ \f -> flip pmatch $ \ctxF ->
+    pnull
+      #$ pfoldr
+      # plam (\x -> ptryDeleteFirstBy # (f # x))
+      # ctxF.stakeOutputDatums
+      # ctxF.stakeInputDatums
+
+-- | Extract the 'PSigContext.signedBy' field from 'PStakeRedeemerHandlerContext'.
+pgetSignedBy ::
+  forall (s :: S).
+  Term
+    s
+    (PStakeRedeemerHandlerContext :--> PSignedBy)
+pgetSignedBy = phoistAcyclic $
+  plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+    sctxF <- pmatchC ctxF.sigContext
+    pure sctxF.signedBy
+
+-- | Return true if the tx is authorized by either the owner or the delegatee.
+pisSignedBy ::
+  forall (s :: S).
+  Term
+    s
+    (PBool :--> PStakeRedeemerHandlerContext :--> PBool)
+pisSignedBy = phoistAcyclic $
+  plam $ \byDelegate ctx ->
+    pmatch (pgetSignedBy # ctx) $ \case
+      PSignedByOwner -> pconstant True
+      PSignedByDelegate -> byDelegate
+      PUnknownSig -> pconstant False
+
+-- | Return true if only the @lockedBy@ field of the stake datum is updated.
+ponlyLocksUpdated ::
+  forall (s :: S).
+  Term
+    s
+    ( ( PBuiltinList (PAsData PProposalLock)
+          :--> PBuiltinList (PAsData PProposalLock)
+      )
+        :--> PStakeRedeemerHandlerContext
+        :--> PBool
+    )
+ponlyLocksUpdated = phoistAcyclic $
+  plam $ \f ->
+    pbatchUpdateInputs #$ plam $ \i o ->
+      pletAll i $ \iF ->
+        let newLocks = f # pfromData iF.lockedBy
+
+            expected =
+              mkRecordConstr
+                PStakeDatum
+                ( #stakedAmount
+                    .= iF.stakedAmount
+                    .& #owner
+                    .= iF.owner
+                    .& #delegatedTo
+                    .= iF.delegatedTo
+                    .& #lockedBy
+                    .= pdata newLocks
+                )
+         in expected #== o
+
+-- | Validation logic shared between 'ppermitVote' and 'retractVote'.
+pvoteHelper ::
+  forall (s :: S).
+  Term
+    s
+    ( ( PStakeRedeemerHandlerContext
+          :--> PBuiltinList (PAsData PProposalLock)
+          :--> PBuiltinList (PAsData PProposalLock)
+      )
+        :--> PStakeRedeemerHandler
+    )
+pvoteHelper = phoistAcyclic $
+  plam $ \valProposalCtx ctx ->
+    -- This puts trust into the Proposal. The Proposal must necessarily check
+    -- that this is not abused.
+    passert
+      "Correct outputs"
+      (ponlyLocksUpdated # (valProposalCtx # ctx) # ctx)
+      (pconstant ())
+
+-- | Add new lock the the existing list of locked.
+paddNewLock ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalLock
+        :--> PBuiltinList (PAsData PProposalLock)
+        :--> PBuiltinList (PAsData PProposalLock)
+    )
+paddNewLock = phoistAcyclic $
+  plam $
+    -- Prepend the lock.
+    \newLock -> pcons # pdata newLock
+
+{- | Default implementation of 'Agora.Stake.PermitVote'.
+
+     @since 1.0.0
+-}
+ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
+ppermitVote = pvoteHelper #$ phoistAcyclic $
+  plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    withOnlyOneStakeInput <- pletC $
+      plam $ \lock -> unTermCont $ do
+        pguardC "Only one stake input allowed" $
+          pisSingleton # ctxF.stakeInputDatums
+
+        pguardC "Owner signs this transaction" $
+          pisSignedBy # pconstant False # ctx
+
+        pure lock
+
+    pure $
+      paddNewLock #$ pmatch ctxF.proposalContext $ \case
+        PSpendProposal proposal redeemer currentTime -> unTermCont $ do
+          mkLock <- pletC $
+            plam $ \action ->
+              mkRecordConstr
+                PProposalLock
+                ( #proposalId
+                    .= pfield @"proposalId"
+                    # proposal
+                    .& #action
+                    .= pdata action
+                )
+
+          pure $
+            pmatch redeemer $ \case
+              PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
+                unTermCont $ do
+                  pguardC "Owner or delegatee signs the transaction" $
+                    pisSignedBy # pconstant True # ctx
+
+                  PFullyBoundedTimeRange _ upperBound <- pmatchC currentTime
+
+                  let action =
+                        mkRecordConstr
+                          PVoted
+                          ( #votedFor
+                              .= pdata voteFor
+                              .& #createdAt
+                              .= pdata upperBound
+                          )
+
+                  pure $ mkLock # action
+              PCosign _ ->
+                let action = pcon $ PCosigned pdnil
+                 in withOnlyOneStakeInput #$ mkLock # action
+              _ -> ptraceError "Expected Vote or Cosign"
+        PNewProposal proposalId ->
+          let action = pcon $ PCreated pdnil
+              lock =
+                mkRecordConstr
+                  PProposalLock
+                  ( #proposalId
+                      .= pdata proposalId
+                      .& #action
+                      .= pdata action
+                  )
+           in withOnlyOneStakeInput # lock
+        _ -> ptraceError "Expected a proposal to be spent or created"
+
+data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
+  deriving stock (Generic)
+  deriving anyclass (PlutusType, PEq)
+
+instance DerivePlutusType PRemoveLocksMode where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Remove stake locks with the proposal id given the list of existing locks.
+     The first parameter controls whether to remove creator locks or not. If
+     one of the locks performed voting action, the unlock cooldown will be
+     checked.
+-}
+premoveLocks ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalId
+        :--> PPOSIXTime
+        :--> PProposalTime
+        :--> PRemoveLocksMode
+        :--> PBuiltinList (PAsData PProposalLock)
+        :--> PBuiltinList (PAsData PProposalLock)
+    )
+premoveLocks =
+  phoistAcyclic $
+    plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do
+      shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks
+
+      PFullyBoundedTimeRange lowerBound _ <- pmatchC currentTime
+
+      let handleVoter
+            ( (pfield @"createdAt" #) ->
+                createdAt
+              ) =
+              let notInCooldown = createdAt + unlockCooldown #<= lowerBound
+               in pif shouldRemoveAllLocks (pconstant True) $
+                    -- Fail the transaction if a voter lock is in cooldown.
+                    passert
+                      "Voter lock shouldn't be in cooldown"
+                      notInCooldown
+                      (pconstant True)
+
+          shouldRemoveLock =
+            flip
+              pletAll
+              ( \lockF ->
+                  foldl1
+                    (#&&)
+                    [ proposalId #== lockF.proposalId
+                    , pmatch lockF.action $ \case
+                        PVoted r -> handleVoter r
+                        _ -> shouldRemoveAllLocks
+                    ]
+              )
+              . pfromData
+
+          -- Return true, given a lock that should be kept.
+          handleLock = plam $ (pnot #) . shouldRemoveLock
+
+      pure $ pfilter # handleLock
+
+{- | Default implementation of 'Agora.Stake.RetractVotes'.
+
+     @since 1.0.0
+-}
+pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
+pretractVote = pvoteHelper #$ phoistAcyclic $
+  plam $ \ctx ->
+    pmatch ctx $ \ctxF ->
+      pmatch ctxF.proposalContext $ \case
+        PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case
+          PUnlockStake _ -> unTermCont $ do
+            proposalF <-
+              pletFieldsC
+                @'[ "proposalId"
+                  , "status"
+                  , "timingConfig"
+                  ]
+                proposal
+
+            let unlockCooldown =
+                  pfield @"minStakeVotingTime"
+                    # proposalF.timingConfig
+
+                mode = pmatch (proposalF.status #== pconstant Finished) $ \case
+                  PTrue -> pcon PRemoveAllLocks
+                  _ -> pcon PRemoveVoterLockOnly
+
+            pguardC "Authorized by either opwner or delegatee" $
+              pisSignedBy # pconstant True # ctx
+
+            pure $
+              premoveLocks
+                # proposalF.proposalId
+                # unlockCooldown
+                # currentTime
+                # mode
+          _ -> ptraceError "Expected unlock"
+        _ -> ptraceError "Expected spending proposal"
+
+-- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
+pdelegateHelper ::
+  forall (s :: S).
+  Term
+    s
+    ( (PStakeRedeemerContext :--> PMaybeData (PAsData PCredential))
+        :--> PStakeRedeemerHandler
+    )
+pdelegateHelper = phoistAcyclic $
+  plam $ \f -> pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+    sigCtxF <- pmatchC ctxF.sigContext
+
+    pguardC "Owner signs this transaction" $
+      pisSignedBy # pconstant False # ctx
+
+    let newDelegate = f # ctxF.redeemerContext
+
+    pguardC "Cannot delegate to the owner" $
+      pmaybeData
+        # pcon PTrue
+        # plam (\pkh -> pnot #$ sigCtxF.owner #== pfromData pkh)
+        # newDelegate
+
+    pguardC "Correct outputs" $
+      pbatchUpdateInputs
+        # plam
+          ( \i o -> pletAll i $ \iF ->
+              mkRecordConstr
+                PStakeDatum
+                ( #stakedAmount
+                    .= iF.stakedAmount
+                    .& #owner
+                    .= iF.owner
+                    .& #delegatedTo
+                    .= pdata newDelegate
+                    .& #lockedBy
+                    .= iF.lockedBy
+                )
+                #== o
+          )
+        # ctx
+
+    pure $ pconstant ()
+
+{- | Default implementation of 'Agora.Stake.DelegateTo'.
+
+     @since 1.0.0
+-}
+pdelegateTo :: forall (s :: S). Term s PStakeRedeemerHandler
+pdelegateTo = pdelegateHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PSetDelegateTo c -> pdjust # pdata c
+      _ -> perror
+
+{- | Default implementation of 'Agora.Stake.ClearDelegate'.
+
+     @since 1.0.0
+-}
+pclearDelegate :: forall (s :: S). Term s PStakeRedeemerHandler
+pclearDelegate = pdelegateHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PNoMetadata -> pdnothing
+      _ -> perror
+
+{- | Default implementation of 'Agora.Stake.Destroy'.
+
+     @since 1.0.0
+-}
+pdestroy :: forall (s :: S). Term s PStakeRedeemerHandler
+pdestroy = phoistAcyclic $
+  pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    pguardC "Owner signs this transaction" $
+      pisSignedBy # pconstant False # ctx
+
+    pguardC "All stakes unlocked" $
+      pnot #$ pany # pstakeLocked # ctxF.stakeInputDatums
+
+    pguardC "All stakes burnt" $
+      pnull # ctxF.stakeOutputDatums
+
+    pure $ pconstant ()
+
+{- | Default implementation of 'Agora.Stake.DepositWithdraw'.
+
+     @since 1.0.0
+-}
+pdepositWithdraw :: forall (s :: S). Term s PStakeRedeemerHandler
+pdepositWithdraw = phoistAcyclic $
+  pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    pguardC "Owner signs this transaction" $
+      pisSignedBy # pconstant False # ctx
+
+    ----------------------------------------------------------------------------
+
+    stakeInputDatum <-
+      pletC $
+        ptrace "Single stake input" $
+          ptryFromSingleton # ctxF.stakeInputDatums
+    stakeInputDatumF <- pletAllC stakeInputDatum
+
+    let stakeOutputDatum =
+          ptrace "Single stake output" $
+            ptryFromSingleton # ctxF.stakeOutputDatums
+
+    ----------------------------------------------------------------------------
+
+    pguardC "Stake unlocked" $
+      pnot #$ pstakeLocked # stakeInputDatum
+
+    ----------------------------------------------------------------------------
+
+    PDepositWithdrawDelta delta <- pmatchC ctxF.redeemerContext
+
+    newStakedAmount <- pletC $ stakeInputDatumF.stakedAmount + delta
+
+    pguardC "Non-negative staked amount" $ 0 #<= newStakedAmount
+
+    let expectedDatum =
+          mkRecordConstr
+            PStakeDatum
+            ( #stakedAmount
+                .= pdata newStakedAmount
+                .& #owner
+                .= stakeInputDatumF.owner
+                .& #delegatedTo
+                .= stakeInputDatumF.delegatedTo
+                .& #lockedBy
+                .= stakeInputDatumF.lockedBy
+            )
+
+    pguardC "Valid output datum" $ expectedDatum #== stakeOutputDatum
+
+    pure $ pconstant ()

agora/Agora/Treasury.hs

@@ -8,123 +8,42 @@ Description: Treasury scripts.
 Contains the datum, redeemer and validator for a template DAO
 treasury.
 -}
-module Agora.Treasury (module Agora.Treasury) where
+module Agora.Treasury (
+  treasuryValidator,
+) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (PValidator)
-import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
-import "plutarch" Plutarch.Api.V1.Value (PValue)
-import Plutarch.Builtin (pforgetData)
-import Plutarch.Extra.IsData (
-  DerivePConstantViaEnum (..),
-  EnumIsData (..),
-  PlutusTypeEnumData,
- )
-import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
-import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
-import Plutarch.TryFrom ()
-import PlutusLedgerApi.V1.Value (CurrencySymbol)
-import PlutusTx qualified
-
-{- | Redeemer for Treasury actions.
-
-     @since 0.1.0
--}
-data TreasuryRedeemer
-  = -- | Allow transaction to pass by delegating to GAT burn.
-    SpendTreasuryGAT
-  deriving stock
-    ( -- | @since 0.1.0
-      Eq
-    , -- | @since 0.1.0
-      Show
-    , -- | @since 0.1.0
-      Generic
-    , -- | @since 0.2.0
-      Enum
-    , -- | @since 0.2.0
-      Bounded
-    )
-  deriving anyclass
-    ( -- | @since 0.2.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 0.1.0
-      PlutusTx.ToData
-    , -- | @since 0.1.0
-      PlutusTx.FromData
-    )
-    via (EnumIsData TreasuryRedeemer)
-
---------------------------------------------------------------------------------
-
-{- | Plutarch level type representing valid redeemers of the
-     treasury.
-
-     @since 0.1.0
--}
-data PTreasuryRedeemer (s :: S)
-  = PSpendTreasuryGAT
-  deriving stock
-    ( -- | @since 0.1.0
-      Generic
-    , -- | @since 0.2.0
-      Bounded
-    , -- | @since 0.2.0
-      Enum
-    )
-  deriving anyclass
-    ( -- | @since 0.1.0
-      PlutusType
-    , -- | @since 0.1.0
-      PIsData
-    )
-
-instance DerivePlutusType PTreasuryRedeemer where
-  type DPTStrat _ = PlutusTypeEnumData
-
--- | @since 0.1.0
-instance PUnsafeLiftDecl PTreasuryRedeemer where
-  type PLifted PTreasuryRedeemer = TreasuryRedeemer
-
--- | @since 0.1.0
-deriving via
-  (DerivePConstantViaEnum TreasuryRedeemer PTreasuryRedeemer)
-  instance
-    (PConstantDecl TreasuryRedeemer)
-
---------------------------------------------------------------------------------
+import Agora.SafeMoney (AuthorityTokenTag)
+import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
+import Plutarch.Api.V2 (PScriptPurpose (PSpending), PValidator)
+import Plutarch.Extra.Tagged (PTagged)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
 
 {- | Validator ensuring that transactions consuming the treasury
      do so in a valid manner.
 
-     @since 0.1.0
+     == Arguments
+
+     Following arguments should be provided(in this order):
+     1. authority token symbol
+
+     @since 1.0.0
 -}
 treasuryValidator ::
-  -- | Governance Authority Token that can unlock this validator.
-  CurrencySymbol ->
-  ClosedTerm PValidator
-treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
+  ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
+treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
   -- plet required fields from script context.
   ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
 
-  -- Ensure that script is for burning i.e. minting a negative amount.
-  PMinting _ <- pmatchC ctx.purpose
-
-  -- Ensure redeemer type is valid.
-  pguardC "Redeemer should be SpendTreasuryGAT" $
-    redeemer #== pforgetData (pconstantData SpendTreasuryGAT)
+  -- Ensure that script is for spending.
+  PSpending _ <- pmatchC ctx.purpose
 
   -- Get the minted value from txInfo.
   txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
   let mint :: Term _ (PValue _ _)
       mint = txInfo.mint
 
-  gatCs <- pletC $ pconstant gatCs'
-
   pguardC "A single authority token has been burned" $
-    singleAuthorityTokenBurned gatCs txInfo.inputs mint
+    singleAuthorityTokenBurned (pfromData atSymbol) txInfo.inputs mint
 
   pure . popaque $ pconstant ()

agora/Agora/Utils.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE QuantifiedConstraints #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {- |
 Module     : Agora.Utils
@@ -9,124 +8,240 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
 Plutarch utility functions that should be upstreamed or don't belong anywhere else.
 -}
 module Agora.Utils (
-  validatorHashToTokenName,
-  mustFindDatum',
-  validatorHashToAddress,
-  pltAsData,
-  withBuiltinPairAsData,
-  CompiledValidator (..),
-  CompiledMintingPolicy (..),
-  CompiledEffect (..),
+  scriptHashToAddress,
+  pstringIntercalate,
+  punwords,
+  pisNothing,
+  pisDNothing,
+  ptoScottEncodingT,
+  ptaggedSymbolValueOf,
+  ptag,
+  puntag,
+  phashDatum,
+  puncurryTuple,
+  psubtractSortedValue,
+  pfindInputWithStateThreadToken,
+  pfindOutputWithStateThreadToken,
+  pisSubValueOf,
 ) where
 
-import Plutarch.Api.V1 (
-  PDatum,
-  PDatumHash,
-  PMaybeData,
+import Plutarch.Api.V1 (AmountGuarantees (Positive), KeyGuarantees (Sorted))
+import Plutarch.Api.V1.AssocMap (punionWith)
+import Plutarch.Api.V1.AssocMap qualified as AssocMap
+import Plutarch.Api.V1.Scripts (PDatumHash (PDatumHash))
+import Plutarch.Api.V2 (
+  AmountGuarantees (NoGuarantees),
+  PCurrencySymbol,
+  PMaybeData (PDNothing),
   PTuple,
+  PTxInInfo,
+  PTxOut,
+  PValue,
  )
-import Plutarch.Builtin (pforgetData)
-import Plutarch.Extra.List (plookupTuple)
-import Plutarch.Extra.Maybe (passertPDJust, passertPJust)
-import Plutarch.Extra.TermCont (ptryFromC)
-import PlutusLedgerApi.V1 (
-  Address (..),
-  Credential (..),
-  MintingPolicy,
-  TokenName (..),
-  Validator,
-  ValidatorHash (..),
+import Plutarch.Builtin (pforgetData, pserialiseData)
+import Plutarch.Crypto (pblake2b_256)
+import Plutarch.DataRepr (punDataSum)
+import Plutarch.Extra.AssetClass (PAssetClass, PAssetClassData, ptoScottEncoding)
+import Plutarch.Extra.Field (pletAll)
+import Plutarch.Extra.Functor (PFunctor (pfmap))
+import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Value (psymbolValueOf)
+import Plutarch.Num (PNum (pnegate, (#+)))
+import Plutarch.Unsafe (punsafeCoerce, punsafeDowncast)
+import PlutusLedgerApi.V2 (
+  Address (Address),
+  Credential (ScriptCredential),
+  ScriptHash,
  )
 
-{- Functions which should (probably) not be upstreamed
-   All of these functions are quite inefficient.
+{- | Create an 'Address' from a given 'ScriptHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
+
+     @since 1.0.0
 -}
+scriptHashToAddress :: ScriptHash -> Address
+scriptHashToAddress vh = Address (ScriptCredential vh) Nothing
 
-{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
-     tokens for extra safety.
+-- | @since 1.0.0
+pstringIntercalate ::
+  forall (s :: S).
+  Term s PString ->
+  [Term s PString] ->
+  Term s PString
+pstringIntercalate _ [x] = x
+pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
+pstringIntercalate _ _ = ""
 
-     @since 0.1.0
--}
-validatorHashToTokenName :: ValidatorHash -> TokenName
-validatorHashToTokenName (ValidatorHash hash) = TokenName hash
+-- | @since 1.0.0
+punwords ::
+  forall (s :: S).
+  [Term s PString] ->
+  Term s PString
+punwords = pstringIntercalate " "
 
-{- | Find datum given a maybe datum hash
-
-     @since 0.1.0
--}
-mustFindDatum' ::
-  forall (datum :: PType).
-  (PIsData datum, PTryFrom PData datum) =>
-  forall s.
-  Term
-    s
-    ( PMaybeData PDatumHash
-        :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
-        :--> datum
-    )
-mustFindDatum' = phoistAcyclic $
-  plam $ \mdh datums -> unTermCont $ do
-    let dh = passertPDJust # "Given TxOut dones't have a datum" # mdh
-        dt = passertPJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
-    (d, _) <- ptryFromC $ pforgetData $ pdata dt
-    pure d
-
-{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
-
-     @since 0.1.0
--}
-validatorHashToAddress :: ValidatorHash -> Address
-validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
-
-{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
-
- @since 0.2.0
--}
-pltAsData ::
+-- | @since 1.0.0
+pisNothing ::
   forall (a :: PType) (s :: S).
-  (POrd a, PIsData a) =>
-  Term s (PAsData a :--> PAsData a :--> PBool)
-pltAsData = phoistAcyclic $
+  Term s (PMaybe a :--> PBool)
+pisNothing = phoistAcyclic $
   plam $
-    \(pfromData -> l) (pfromData -> r) -> l #< r
+    flip pmatch $ \case
+      PNothing -> pconstant True
+      _ -> pconstant False
 
-{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
+-- | @since 1.0.0
+pisDNothing ::
+  forall (a :: PType) (s :: S).
+  Term s (PMaybeData a :--> PBool)
+pisDNothing = phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PDNothing _ -> pconstant True
+      _ -> pconstant False
 
-     @since 0.2.0
+-- | @since 1.0.0
+ptoScottEncodingT ::
+  forall {k :: Type} (unit :: k) (s :: S).
+  Term s (PTagged unit PAssetClassData :--> PTagged unit PAssetClass)
+ptoScottEncodingT = phoistAcyclic $
+  plam $ \d ->
+    punsafeDowncast $ ptoScottEncoding #$ pto d
+
+{- | Get the sum of all values belonging to a particular tagged 'CurrencySymbol'.
+
+     @since 1.0.0
 -}
-withBuiltinPairAsData ::
-  forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
+ptaggedSymbolValueOf ::
+  forall
+    {k :: Type}
+    (unit :: k)
+    (keys :: KeyGuarantees)
+    (amounts :: AmountGuarantees)
+    (s :: S).
+  Term s (PTagged unit PCurrencySymbol :--> (PValue keys amounts :--> PInteger))
+ptaggedSymbolValueOf = phoistAcyclic $ plam $ \tcs -> psymbolValueOf # pto tcs
+
+-- | @since 1.0.0
+ptag ::
+  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
+  Term s a ->
+  Term s (PTagged tag a)
+ptag = punsafeDowncast
+
+-- | @since 1.0.0
+puntag ::
+  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
+  Term s (PTagged tag a) ->
+  Term s a
+puntag = pto
+
+{- | Hash the given datum using the correct algorithm(blake2b_256).
+
+     Note: check the discussion here: https://github.com/input-output-hk/cardano-ledger/issues/2941.
+
+     @since 1.0.0
+-}
+phashDatum ::
+  forall (a :: PType) (s :: S).
+  PIsData a =>
+  Term s (a :--> PDatumHash)
+phashDatum =
+  phoistAcyclic $
+    plam $
+      pcon
+        . PDatumHash
+        . (pblake2b_256 #)
+        . (pserialiseData #)
+        . pforgetData
+        . pdata
+
+puncurryTuple ::
+  forall (c :: PType) (a :: PType) (b :: PType) (s :: S).
   (PIsData a, PIsData b) =>
-  (Term s a -> Term s b -> Term s c) ->
+  Term s ((a :--> b :--> c) :--> PTuple a b :--> c)
+puncurryTuple = phoistAcyclic $
+  plam $
+    \f ((punDataSum #) -> r) ->
+      pletAll r $ \rF -> f # rF._0 # rF._1
+
+psubtractSortedValue ::
+  forall (ag :: AmountGuarantees) (s :: S).
   Term
     s
-    (PBuiltinPair (PAsData a) (PAsData b)) ->
-  Term s c
-withBuiltinPairAsData f p =
-  let a = pfromData $ pfstBuiltin # p
-      b = pfromData $ psndBuiltin # p
-   in f a b
+    ( PValue 'Sorted ag
+        :--> PValue 'Sorted ag
+        :--> PValue 'Sorted 'NoGuarantees
+    )
+psubtractSortedValue = phoistAcyclic $ plam $ \a b ->
+  punsafeCoerce $
+    punionWith
+      # (punionWith # plam (#+))
+      # pto a
+      #$ pfmap
+      # (pfmap # pnegate)
+      # pto b
 
-{- | Type-safe wrapper for compiled plutus validator.
+{- | Find an input containing exactly one token with the given currency symbol
 
-     @since 0.2.0
+     @since 1.0.0
 -}
-newtype CompiledValidator (datum :: Type) (redeemer :: Type) = CompiledValidator
-  { getCompiledValidator :: Validator
-  }
+pfindInputWithStateThreadToken ::
+  forall tag.
+  ClosedTerm
+    ( PTagged tag PCurrencySymbol
+        :--> PBuiltinList PTxInInfo
+        :--> PMaybe PTxInInfo
+    )
+pfindInputWithStateThreadToken = plam $ \tokenSymbol inputs ->
+  pfind
+    # ( plam $ \input ->
+          ptaggedSymbolValueOf
+            # tokenSymbol
+            # (pfield @"value" # (pfield @"resolved" # input))
+            #== 1
+      )
+    # inputs
 
-{- | Type-safe wrapper for compiled plutus miting policy.
+{- | Find an output containing exactly one token with the given currency symbol,
 
-     @since 0.2.0
+     @since 1.0.0
 -}
-newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
-  { getCompiledMintingPolicy :: MintingPolicy
-  }
+pfindOutputWithStateThreadToken ::
+  forall tag.
+  ClosedTerm
+    ( PTagged tag PCurrencySymbol
+        :--> PBuiltinList PTxOut
+        :--> PMaybe PTxOut
+    )
+pfindOutputWithStateThreadToken = plam $ \tokenSymbol outputs ->
+  pfind
+    # ( plam $ \output ->
+          ( ptaggedSymbolValueOf
+              # tokenSymbol
+              # (pfield @"value" # output)
+              #== 1
+          )
+      )
+    # outputs
 
-{- | Type-safe wrapper for compiled plutus effect.
+pisNonNegativeValue ::
+  forall (kg :: KeyGuarantees) (am :: AmountGuarantees) (s :: S).
+  Term s (PValue kg am :--> PBool)
+pisNonNegativeValue =
+  phoistAcyclic $
+    plam $
+      (AssocMap.pall # (AssocMap.pall # plam (0 #<=)) #)
+        . pto
 
-     @since 0.2.0
--}
-newtype CompiledEffect (datum :: Type) = CompiledEffect
-  { getCompiledEffect :: Validator
-  }
+pisSubValueOf ::
+  forall (s :: S).
+  Term
+    s
+    ( PValue 'Sorted 'Positive
+        :--> PValue 'Sorted 'Positive
+        :--> PBool
+    )
+pisSubValueOf = phoistAcyclic $ plam $ \vl vr ->
+  pisNonNegativeValue
+    #$ psubtractSortedValue
+    # vl
+    # vr

docs/README.md

@@ -1,21 +0,0 @@
-# Agora specification and documentation
-
-This folder contains documents explaining the conceptual background and technical implementation of Agora components.
-
-## Technical design
-
-The `tech-design/` subdirectory contains high level descriptions of the architecture of Agora's governance solution.
-
-## Plutarch
-
-Agora makes extensive use of [Plutarch](https://github.com/plutonomicon/plutarch). One unfamiliar with the library will be unable to suitably understand the technical parts of this documentation. The maintainers provide an extensive [guide](https://github.com/Plutonomicon/plutarch/blob/master/docs/GUIDE.md) that will familiarise the developer with the language and thereby this set of documentation.
-
-## Glossary
-
-The following is a list of terms that are used frequently throughout the documentation:
-
--   **DAO**: decentralised autonomous organisation.
--   **Proposal**: a set of changes to a Cardano protocol, suggested by a community member. Will be enacted, if passed by the community.
--   **Governance token (GT)**: the token that confers the right to vote on proposals within the protocol. May affect the user's eligibility for rewards. Examples include Liqwid's LQ.
--   **Governance authority token (GAT)**: A token that grants the effects of a proposal the authority to alter the system. More information can be read [here](https://liqwid.notion.site/Authority-Tokens-b25d2011c8114e04ac9e73514e6b9421).
--   **Effect**: A script for implementing changes suggested by a proposal. An effect can make numerous changes and a proposal may have multiple effects.

docs/diagrams/GovernanceAuthorityToken.dot

@@ -1,238 +0,0 @@
-digraph GovernanceAuthorityToken {
-
-  rankdir = LR;
-  // Inputs:
-
-  //////////////////////////////////////////////////////////////////////////////
-  // governance in
-  governance_datum
-    [ shape = record
-    , label =
-        "{{ GovernanceState
-        }}"
-    ];
-
-  governance_addr
-    [ shape = record
-    , label = "{{ Script | Governance }}"
-    , style = "bold"
-    ];
-
-  //////////////////////////////////////////////////////////////////////////////
-  // proposal in
-  proposal_datum
-    [ shape = record
-    , label = "{{ ProposalState }}"
-    ];
-
-  proposal_addr
-    -> proposal_redeemer
-    [style = "dashed", dir="none"];
-
-  proposal_addr
-    [ shape = record
-    , label = "{{ Script | Proposal }}"
-    , style = "bold"
-    ];
-
-  governance_datum
-    -> governance_addr [style = "dashed"];
-
-  governance_redeemer
-    [ shape = record
-    , label = "{{ GovernanceAction | MintAuthorityTokens }}"
-    ];
-
-  governance_addr
-    -> governance_redeemer
-      [style = "dashed", dir="none"];
-
-  proposal_datum -> proposal_addr [style = "dashed"];
-
-  //////////////////////////////////////////////////////////////////////////////
-  // user wallet in
-  user_wallet_min_ada_in
-    [ shape = ellipse
-    , label = <ADA: <I>min utxo</I>>
-    ];
-
-  user_wallet_in
-    [ shape = box
-    , label = "User Inputs"
-    , style = "bold"
-    , peripheries = 2
-    ];
-
-  user_wallet_min_ada_in
-    -> user_wallet_in
-    [ style = "dashed"
-    ];
-
-
-  tx1
-    [ shape = diamond
-    , label = "Tx1"
-    , style = "bold"
-    ];
-
-  user_wallet_in -> tx1;
-  governance_addr -> tx1;
-  proposal_addr -> tx1;
-
-  //////////////////////////////////////////////////////////////////////////////
-  // governance out
-  governance_datum_out
-    [ shape = record
-    , label =
-        "{{ GovernanceState
-        }}"
-    ];
-
-  governance_addr_out
-    [ shape = record
-    , label = "{{ Script | Governance }}"
-    , style = "bold"
-    ];
-
-
-  governance_datum_out
-    -> governance_addr_out
-    [ style = "dashed"
-    ];
-
-  //////////////////////////////////////////////////////////////////////////////
-  // proposal out
-  proposal_datum_out
-    -> proposal_addr_out
-    [ style = "dashed"
-    ];
-
-  proposal_redeemer
-    [ shape = record
-    , label =
-    "{{ ProposalAction | FinishVoting }}"
-    ];
-
-
-  proposal_datum_out
-    [ shape = record
-    , label =
-    "{{ ProposalState }}"
-    ];
-
-  proposal_addr_out
-    [ shape = record
-    , label = "{{ Script | Proposal }}"
-    , style = "bold"
-    ];
-
-
-  //////////////////////////////////////////////////////////////////////////////
-  // effect out
-  effect_governance_token_out
-    [ shape = ellipse
-    , label = <GovernanceAuthorityToken: 1>
-    ];
-
-  effect_addr_out
-    [ shape = record
-    , label = "{{ Script | Effect }}"
-    , style = "bold"
-    ];
-
-  effect_governance_token_out
-    -> effect_addr_out
-    [ style = "dashed"
-    ];
-
-  effect_min_ada_out
-    -> effect_addr_out
-    [ style = "dashed"
-    ];
-
-  effect_min_ada_out
-    [ shape = ellipse
-    , label = <ADA: <I>min utxo</I>>
-    ];
-
-  tx1 -> governance_addr_out;
-  tx1 -> proposal_addr_out;
-  tx1 -> effect_addr_out;
-
-  //////////////////////////////////////////////////////////////////////////////
-  //////////////////////////////////////////////////////////////////////////////
-
-  //////////////////////////////////////////////////////////////////////////////
-  // effect in
-  effect_addr_out2
-    [ shape = record
-    , label = "{{ Script | Effect }}"
-    , style = "bold"
-    ];
-
-  //////////////////////////////////////////////////////////////////////////////
-  // market in
-  market_addr_in
-    [ shape = record
-    , label = "{{ Script | Market }}"
-    , style = "bold"
-    ];
-
-  market_datum_in
-    [ shape = record
-    , label = "{{ MarketState | params: A }}"
-    ];
-
-  market_datum_in
-    -> market_addr_in
-    [ style = "dashed"
-    ];
-
-  //////////////////////////////////////////////////////////////////////////////
-  // market out
-  market_addr_out
-    [ shape = record
-    , label = "{{ Script | Market }}"
-    , style = "bold"
-    ];
-
-  market_datum_out
-    [ shape = record
-    , label = "{{ MarketState | params: f(A) }}"
-    ];
-
-  market_datum_out
-    -> market_addr_out
-    [ style = "dashed"
-    ];
-
-  tx2
-    [ shape = diamond
-    , label = "Tx2"
-    , style = "bold"
-    ];
-
-  user_wallet_min_ada_out
-    [ shape = ellipse
-    , label = <ADA: <I>min utxo</I>>
-    ];
-
-  user_wallet_out
-    [ shape = box
-    , label = "User Outputs"
-    , style = "bold"
-    , peripheries = 2
-    ];
-
-  user_wallet_min_ada_out
-    -> user_wallet_out
-    [ style = "dashed"
-    ];
-
-  effect_addr_out -> tx2;
-  market_addr_in -> tx2;
-  tx2 -> user_wallet_out;
-  tx2 -> effect_addr_out2;
-  tx2 -> market_addr_out;
-
-}

docs/diagrams/GovernanceAuthorityToken.svg

@@ -1,322 +0,0 @@
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
- "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
-<!-- Generated by graphviz version 2.47.3 (0)
- -->
-<!-- Title: GovernanceAuthorityToken Pages: 1 -->
-<svg width="1129pt" height="459pt"
- viewBox="0.00 0.00 1128.65 459.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
-<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 455)">
-<title>GovernanceAuthorityToken</title>
-<polygon fill="white" stroke="transparent" points="-4,4 -4,-455 1124.65,-455 1124.65,4 -4,4"/>
-<!-- governance_datum -->
-<g id="node1" class="node">
-<title>governance_datum</title>
-<polygon fill="none" stroke="black" points="7.99,-383.5 7.99,-419.5 147.99,-419.5 147.99,-383.5 7.99,-383.5"/>
-<text text-anchor="middle" x="77.99" y="-397.8" font-family="Times,serif" font-size="14.00">GovernanceState</text>
-</g>
-<!-- governance_addr -->
-<g id="node2" class="node">
-<title>governance_addr</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="195.99,-378.5 195.99,-424.5 296.99,-424.5 296.99,-378.5 195.99,-378.5"/>
-<text text-anchor="middle" x="246.49" y="-409.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="195.99,-401.5 296.99,-401.5 "/>
-<text text-anchor="middle" x="246.49" y="-386.3" font-family="Times,serif" font-size="14.00">Governance</text>
-</g>
-<!-- governance_datum&#45;&gt;governance_addr -->
-<g id="edge2" class="edge">
-<title>governance_datum&#45;&gt;governance_addr</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M148.15,-401.5C160.65,-401.5 173.58,-401.5 185.77,-401.5"/>
-<polygon fill="black" stroke="black" points="185.82,-405 195.82,-401.5 185.82,-398 185.82,-405"/>
-</g>
-<!-- governance_redeemer -->
-<g id="node6" class="node">
-<title>governance_redeemer</title>
-<polygon fill="none" stroke="black" points="402.32,-404.5 402.32,-450.5 569.32,-450.5 569.32,-404.5 402.32,-404.5"/>
-<text text-anchor="middle" x="485.82" y="-435.3" font-family="Times,serif" font-size="14.00">GovernanceAction</text>
-<polyline fill="none" stroke="black" points="402.32,-427.5 569.32,-427.5 "/>
-<text text-anchor="middle" x="485.82" y="-412.3" font-family="Times,serif" font-size="14.00">MintAuthorityTokens</text>
-</g>
-<!-- governance_addr&#45;&gt;governance_redeemer -->
-<g id="edge3" class="edge">
-<title>governance_addr&#45;&gt;governance_redeemer</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M297.24,-406.95C327.55,-410.27 367.04,-414.6 401.97,-418.42"/>
-</g>
-<!-- tx1 -->
-<g id="node9" class="node">
-<title>tx1</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="485.82,-330.5 446.28,-312.5 485.82,-294.5 525.37,-312.5 485.82,-330.5"/>
-<text text-anchor="middle" x="485.82" y="-308.8" font-family="Times,serif" font-size="14.00">Tx1</text>
-</g>
-<!-- governance_addr&#45;&gt;tx1 -->
-<g id="edge7" class="edge">
-<title>governance_addr&#45;&gt;tx1</title>
-<path fill="none" stroke="black" d="M275.17,-378.21C292.02,-365.2 314.58,-349.78 336.99,-340.5 370.45,-326.64 411.03,-319.58 441.2,-316.02"/>
-<polygon fill="black" stroke="black" points="441.85,-319.47 451.41,-314.9 441.09,-312.51 441.85,-319.47"/>
-</g>
-<!-- proposal_datum -->
-<g id="node3" class="node">
-<title>proposal_datum</title>
-<polygon fill="none" stroke="black" points="19.49,-118.5 19.49,-154.5 136.49,-154.5 136.49,-118.5 19.49,-118.5"/>
-<text text-anchor="middle" x="77.99" y="-132.8" font-family="Times,serif" font-size="14.00">ProposalState</text>
-</g>
-<!-- proposal_addr -->
-<g id="node4" class="node">
-<title>proposal_addr</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="206.99,-113.5 206.99,-159.5 285.99,-159.5 285.99,-113.5 206.99,-113.5"/>
-<text text-anchor="middle" x="246.49" y="-144.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="206.99,-136.5 285.99,-136.5 "/>
-<text text-anchor="middle" x="246.49" y="-121.3" font-family="Times,serif" font-size="14.00">Proposal</text>
-</g>
-<!-- proposal_datum&#45;&gt;proposal_addr -->
-<g id="edge4" class="edge">
-<title>proposal_datum&#45;&gt;proposal_addr</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M136.76,-136.5C156.33,-136.5 177.98,-136.5 196.78,-136.5"/>
-<polygon fill="black" stroke="black" points="196.9,-140 206.9,-136.5 196.9,-133 196.9,-140"/>
-</g>
-<!-- proposal_redeemer -->
-<g id="node5" class="node">
-<title>proposal_redeemer</title>
-<polygon fill="none" stroke="black" points="423.82,-0.5 423.82,-46.5 547.82,-46.5 547.82,-0.5 423.82,-0.5"/>
-<text text-anchor="middle" x="485.82" y="-31.3" font-family="Times,serif" font-size="14.00">ProposalAction</text>
-<polyline fill="none" stroke="black" points="423.82,-23.5 547.82,-23.5 "/>
-<text text-anchor="middle" x="485.82" y="-8.3" font-family="Times,serif" font-size="14.00">FinishVoting</text>
-</g>
-<!-- proposal_addr&#45;&gt;proposal_redeemer -->
-<g id="edge1" class="edge">
-<title>proposal_addr&#45;&gt;proposal_redeemer</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M266.76,-113.35C283.45,-94.86 309.21,-69.76 336.99,-55.5 363.73,-41.77 396.13,-33.92 423.77,-29.43"/>
-</g>
-<!-- proposal_addr&#45;&gt;tx1 -->
-<g id="edge8" class="edge">
-<title>proposal_addr&#45;&gt;tx1</title>
-<path fill="none" stroke="black" d="M254.73,-159.73C266.38,-193.02 292.59,-253.67 336.99,-284.5 366.58,-305.05 407.19,-311.59 438.36,-313.24"/>
-<polygon fill="black" stroke="black" points="438.41,-316.75 448.54,-313.63 438.68,-309.75 438.41,-316.75"/>
-</g>
-<!-- user_wallet_min_ada_in -->
-<g id="node7" class="node">
-<title>user_wallet_min_ada_in</title>
-<ellipse fill="none" stroke="black" cx="77.99" cy="-312.5" rx="77.99" ry="18"/>
-<text text-anchor="start" x="25.99" y="-309.8" font-family="Times,serif" font-size="14.00">ADA: </text>
-<text text-anchor="start" x="65.99" y="-309.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
-</g>
-<!-- user_wallet_in -->
-<g id="node8" class="node">
-<title>user_wallet_in</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="296.99,-330.5 195.99,-330.5 195.99,-294.5 296.99,-294.5 296.99,-330.5"/>
-<polygon fill="none" stroke="black" stroke-width="2" points="300.99,-334.5 191.99,-334.5 191.99,-290.5 300.99,-290.5 300.99,-334.5"/>
-<text text-anchor="middle" x="246.49" y="-308.8" font-family="Times,serif" font-size="14.00">User Inputs</text>
-</g>
-<!-- user_wallet_min_ada_in&#45;&gt;user_wallet_in -->
-<g id="edge5" class="edge">
-<title>user_wallet_min_ada_in&#45;&gt;user_wallet_in</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M156.39,-312.5C164.75,-312.5 173.19,-312.5 181.37,-312.5"/>
-<polygon fill="black" stroke="black" points="181.56,-316 191.56,-312.5 181.56,-309 181.56,-316"/>
-</g>
-<!-- user_wallet_in&#45;&gt;tx1 -->
-<g id="edge6" class="edge">
-<title>user_wallet_in&#45;&gt;tx1</title>
-<path fill="none" stroke="black" d="M301.05,-312.5C341.58,-312.5 396.8,-312.5 436.1,-312.5"/>
-<polygon fill="black" stroke="black" points="436.24,-316 446.24,-312.5 436.24,-309 436.24,-316"/>
-</g>
-<!-- governance_addr_out -->
-<g id="node11" class="node">
-<title>governance_addr_out</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="670.66,-331.5 670.66,-377.5 771.66,-377.5 771.66,-331.5 670.66,-331.5"/>
-<text text-anchor="middle" x="721.16" y="-362.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="670.66,-354.5 771.66,-354.5 "/>
-<text text-anchor="middle" x="721.16" y="-339.3" font-family="Times,serif" font-size="14.00">Governance</text>
-</g>
-<!-- tx1&#45;&gt;governance_addr_out -->
-<g id="edge13" class="edge">
-<title>tx1&#45;&gt;governance_addr_out</title>
-<path fill="none" stroke="black" d="M514.51,-317.48C550.27,-323.92 613.5,-335.3 660.44,-343.75"/>
-<polygon fill="black" stroke="black" points="660.03,-347.23 670.49,-345.56 661.27,-340.34 660.03,-347.23"/>
-</g>
-<!-- proposal_addr_out -->
-<g id="node13" class="node">
-<title>proposal_addr_out</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="681.66,-244.5 681.66,-290.5 760.66,-290.5 760.66,-244.5 681.66,-244.5"/>
-<text text-anchor="middle" x="721.16" y="-275.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="681.66,-267.5 760.66,-267.5 "/>
-<text text-anchor="middle" x="721.16" y="-252.3" font-family="Times,serif" font-size="14.00">Proposal</text>
-</g>
-<!-- tx1&#45;&gt;proposal_addr_out -->
-<g id="edge14" class="edge">
-<title>tx1&#45;&gt;proposal_addr_out</title>
-<path fill="none" stroke="black" d="M514.36,-307.36C544.06,-301.8 592.73,-292.64 634.66,-284.5 646.61,-282.18 659.5,-279.64 671.55,-277.24"/>
-<polygon fill="black" stroke="black" points="672.32,-280.66 681.44,-275.28 670.95,-273.8 672.32,-280.66"/>
-</g>
-<!-- effect_addr_out -->
-<g id="node15" class="node">
-<title>effect_addr_out</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="691.16,-169.5 691.16,-215.5 751.16,-215.5 751.16,-169.5 691.16,-169.5"/>
-<text text-anchor="middle" x="721.16" y="-200.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="691.16,-192.5 751.16,-192.5 "/>
-<text text-anchor="middle" x="721.16" y="-177.3" font-family="Times,serif" font-size="14.00">Effect</text>
-</g>
-<!-- tx1&#45;&gt;effect_addr_out -->
-<g id="edge15" class="edge">
-<title>tx1&#45;&gt;effect_addr_out</title>
-<path fill="none" stroke="black" d="M524.56,-312.91C556.23,-311.58 601.5,-305.62 634.66,-284.5 657.76,-269.79 652.08,-254.62 670.66,-234.5 674.63,-230.2 679.02,-225.92 683.5,-221.83"/>
-<polygon fill="black" stroke="black" points="685.89,-224.39 691.07,-215.14 681.26,-219.14 685.89,-224.39"/>
-</g>
-<!-- governance_datum_out -->
-<g id="node10" class="node">
-<title>governance_datum_out</title>
-<polygon fill="none" stroke="black" points="415.82,-349.5 415.82,-385.5 555.82,-385.5 555.82,-349.5 415.82,-349.5"/>
-<text text-anchor="middle" x="485.82" y="-363.8" font-family="Times,serif" font-size="14.00">GovernanceState</text>
-</g>
-<!-- governance_datum_out&#45;&gt;governance_addr_out -->
-<g id="edge9" class="edge">
-<title>governance_datum_out&#45;&gt;governance_addr_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M555.88,-363.65C589.11,-361.8 628.55,-359.6 660.46,-357.83"/>
-<polygon fill="black" stroke="black" points="660.75,-361.32 670.54,-357.26 660.36,-354.33 660.75,-361.32"/>
-</g>
-<!-- proposal_datum_out -->
-<g id="node12" class="node">
-<title>proposal_datum_out</title>
-<polygon fill="none" stroke="black" points="427.32,-239.5 427.32,-275.5 544.32,-275.5 544.32,-239.5 427.32,-239.5"/>
-<text text-anchor="middle" x="485.82" y="-253.8" font-family="Times,serif" font-size="14.00">ProposalState</text>
-</g>
-<!-- proposal_datum_out&#45;&gt;proposal_addr_out -->
-<g id="edge10" class="edge">
-<title>proposal_datum_out&#45;&gt;proposal_addr_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M544.5,-259.97C583.48,-261.64 634.39,-263.82 671.36,-265.41"/>
-<polygon fill="black" stroke="black" points="671.25,-268.91 681.39,-265.84 671.55,-261.91 671.25,-268.91"/>
-</g>
-<!-- effect_governance_token_out -->
-<g id="node14" class="node">
-<title>effect_governance_token_out</title>
-<ellipse fill="none" stroke="black" cx="485.82" cy="-202.5" rx="148.67" ry="18"/>
-<text text-anchor="start" x="379.32" y="-198.8" font-family="Times,serif" font-size="14.00">GovernanceAuthorityToken: 1</text>
-</g>
-<!-- effect_governance_token_out&#45;&gt;effect_addr_out -->
-<g id="edge11" class="edge">
-<title>effect_governance_token_out&#45;&gt;effect_addr_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M626.26,-196.52C646.19,-195.67 665.2,-194.86 680.83,-194.19"/>
-<polygon fill="black" stroke="black" points="681.24,-197.67 691.08,-193.75 680.94,-190.68 681.24,-197.67"/>
-</g>
-<!-- tx2 -->
-<g id="node22" class="node">
-<title>tx2</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="885.65,-168.5 846.11,-150.5 885.65,-132.5 925.2,-150.5 885.65,-168.5"/>
-<text text-anchor="middle" x="885.65" y="-146.8" font-family="Times,serif" font-size="14.00">Tx2</text>
-</g>
-<!-- effect_addr_out&#45;&gt;tx2 -->
-<g id="edge19" class="edge">
-<title>effect_addr_out&#45;&gt;tx2</title>
-<path fill="none" stroke="black" d="M751.21,-184.99C778.89,-177.84 820.59,-167.06 850,-159.46"/>
-<polygon fill="black" stroke="black" points="851.04,-162.8 859.84,-156.91 849.28,-156.03 851.04,-162.8"/>
-</g>
-<!-- effect_min_ada_out -->
-<g id="node16" class="node">
-<title>effect_min_ada_out</title>
-<ellipse fill="none" stroke="black" cx="485.82" cy="-148.5" rx="77.99" ry="18"/>
-<text text-anchor="start" x="433.82" y="-145.8" font-family="Times,serif" font-size="14.00">ADA: </text>
-<text text-anchor="start" x="473.82" y="-145.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
-</g>
-<!-- effect_min_ada_out&#45;&gt;effect_addr_out -->
-<g id="edge12" class="edge">
-<title>effect_min_ada_out&#45;&gt;effect_addr_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M548,-159.45C574.64,-164.28 606.21,-170.07 634.66,-175.5 649.73,-178.37 666.28,-181.64 680.76,-184.53"/>
-<polygon fill="black" stroke="black" points="680.41,-188.03 690.9,-186.56 681.78,-181.17 680.41,-188.03"/>
-</g>
-<!-- effect_addr_out2 -->
-<g id="node17" class="node">
-<title>effect_addr_out2</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="1030.15,-127.5 1030.15,-173.5 1090.15,-173.5 1090.15,-127.5 1030.15,-127.5"/>
-<text text-anchor="middle" x="1060.15" y="-158.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="1030.15,-150.5 1090.15,-150.5 "/>
-<text text-anchor="middle" x="1060.15" y="-135.3" font-family="Times,serif" font-size="14.00">Effect</text>
-</g>
-<!-- market_addr_in -->
-<g id="node18" class="node">
-<title>market_addr_in</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="687.16,-85.5 687.16,-131.5 755.16,-131.5 755.16,-85.5 687.16,-85.5"/>
-<text text-anchor="middle" x="721.16" y="-116.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="687.16,-108.5 755.16,-108.5 "/>
-<text text-anchor="middle" x="721.16" y="-93.3" font-family="Times,serif" font-size="14.00">Market</text>
-</g>
-<!-- market_addr_in&#45;&gt;tx2 -->
-<g id="edge20" class="edge">
-<title>market_addr_in&#45;&gt;tx2</title>
-<path fill="none" stroke="black" d="M755.43,-117.1C783.05,-124.24 822.2,-134.36 850.15,-141.58"/>
-<polygon fill="black" stroke="black" points="849.35,-144.99 859.9,-144.1 851.1,-138.21 849.35,-144.99"/>
-</g>
-<!-- market_datum_in -->
-<g id="node19" class="node">
-<title>market_datum_in</title>
-<polygon fill="none" stroke="black" points="432.32,-65.5 432.32,-111.5 539.32,-111.5 539.32,-65.5 432.32,-65.5"/>
-<text text-anchor="middle" x="485.82" y="-96.3" font-family="Times,serif" font-size="14.00">MarketState</text>
-<polyline fill="none" stroke="black" points="432.32,-88.5 539.32,-88.5 "/>
-<text text-anchor="middle" x="485.82" y="-73.3" font-family="Times,serif" font-size="14.00">params: A</text>
-</g>
-<!-- market_datum_in&#45;&gt;market_addr_in -->
-<g id="edge16" class="edge">
-<title>market_datum_in&#45;&gt;market_addr_in</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M539.48,-93.01C580.88,-96.56 637.87,-101.45 676.7,-104.77"/>
-<polygon fill="black" stroke="black" points="676.88,-108.3 687.14,-105.67 677.48,-101.33 676.88,-108.3"/>
-</g>
-<!-- market_addr_out -->
-<g id="node20" class="node">
-<title>market_addr_out</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="1026.15,-192.5 1026.15,-238.5 1094.15,-238.5 1094.15,-192.5 1026.15,-192.5"/>
-<text text-anchor="middle" x="1060.15" y="-223.3" font-family="Times,serif" font-size="14.00">Script</text>
-<polyline fill="none" stroke="black" stroke-width="2" points="1026.15,-215.5 1094.15,-215.5 "/>
-<text text-anchor="middle" x="1060.15" y="-200.3" font-family="Times,serif" font-size="14.00">Market</text>
-</g>
-<!-- market_datum_out -->
-<g id="node21" class="node">
-<title>market_datum_out</title>
-<polygon fill="none" stroke="black" points="832.15,-192.5 832.15,-238.5 939.15,-238.5 939.15,-192.5 832.15,-192.5"/>
-<text text-anchor="middle" x="885.65" y="-223.3" font-family="Times,serif" font-size="14.00">MarketState</text>
-<polyline fill="none" stroke="black" points="832.15,-215.5 939.15,-215.5 "/>
-<text text-anchor="middle" x="885.65" y="-200.3" font-family="Times,serif" font-size="14.00">params: f(A)</text>
-</g>
-<!-- market_datum_out&#45;&gt;market_addr_out -->
-<g id="edge17" class="edge">
-<title>market_datum_out&#45;&gt;market_addr_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M939.34,-215.5C963.83,-215.5 992.59,-215.5 1015.8,-215.5"/>
-<polygon fill="black" stroke="black" points="1016.03,-219 1026.03,-215.5 1016.03,-212 1016.03,-219"/>
-</g>
-<!-- tx2&#45;&gt;effect_addr_out2 -->
-<g id="edge22" class="edge">
-<title>tx2&#45;&gt;effect_addr_out2</title>
-<path fill="none" stroke="black" d="M925.36,-150.5C953.46,-150.5 991.35,-150.5 1019.63,-150.5"/>
-<polygon fill="black" stroke="black" points="1019.96,-154 1029.96,-150.5 1019.96,-147 1019.96,-154"/>
-</g>
-<!-- tx2&#45;&gt;market_addr_out -->
-<g id="edge23" class="edge">
-<title>tx2&#45;&gt;market_addr_out</title>
-<path fill="none" stroke="black" d="M907.8,-158.47C934.78,-168.63 982.05,-186.45 1016.61,-199.47"/>
-<polygon fill="black" stroke="black" points="1015.4,-202.75 1025.99,-203.01 1017.87,-196.2 1015.4,-202.75"/>
-</g>
-<!-- user_wallet_out -->
-<g id="node24" class="node">
-<title>user_wallet_out</title>
-<polygon fill="none" stroke="black" stroke-width="2" points="1116.65,-104.5 1003.65,-104.5 1003.65,-68.5 1116.65,-68.5 1116.65,-104.5"/>
-<polygon fill="none" stroke="black" stroke-width="2" points="1120.65,-108.5 999.65,-108.5 999.65,-64.5 1120.65,-64.5 1120.65,-108.5"/>
-<text text-anchor="middle" x="1060.15" y="-82.8" font-family="Times,serif" font-size="14.00">User Outputs</text>
-</g>
-<!-- tx2&#45;&gt;user_wallet_out -->
-<g id="edge21" class="edge">
-<title>tx2&#45;&gt;user_wallet_out</title>
-<path fill="none" stroke="black" d="M908.15,-142.52C928.69,-134.9 960.76,-123 990.08,-112.12"/>
-<polygon fill="black" stroke="black" points="991.33,-115.4 999.49,-108.64 988.89,-108.83 991.33,-115.4"/>
-</g>
-<!-- user_wallet_min_ada_out -->
-<g id="node23" class="node">
-<title>user_wallet_min_ada_out</title>
-<ellipse fill="none" stroke="black" cx="885.65" cy="-86.5" rx="77.99" ry="18"/>
-<text text-anchor="start" x="833.65" y="-83.8" font-family="Times,serif" font-size="14.00">ADA: </text>
-<text text-anchor="start" x="873.65" y="-83.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
-</g>
-<!-- user_wallet_min_ada_out&#45;&gt;user_wallet_out -->
-<g id="edge18" class="edge">
-<title>user_wallet_min_ada_out&#45;&gt;user_wallet_out</title>
-<path fill="none" stroke="black" stroke-dasharray="5,2" d="M963.82,-86.5C972.36,-86.5 981.03,-86.5 989.47,-86.5"/>
-<polygon fill="black" stroke="black" points="989.64,-90 999.64,-86.5 989.64,-83 989.64,-90"/>
-</g>
-</g>
-</svg>

docs/diagrams/UsingAgora.dot

@@ -1,6 +0,0 @@
-digraph {
-  rankdir=LR
-  Users -> Proposals [label="vote on"]
-  Proposals -> Effects [label="have one or many"]
-  Effects -> Components [label="alter"]
-}

docs/diagrams/UsingAgora.svg

@@ -1,57 +0,0 @@
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
- "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
-<!-- Generated by graphviz version 2.49.3 (0)
- -->
-<!-- Pages: 1 -->
-<svg width="742pt" height="44pt"
- viewBox="0.00 0.00 742.06 44.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
-<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 40)">
-<polygon fill="white" stroke="transparent" points="-4,4 -4,-40 738.06,-40 738.06,4 -4,4"/>
-<!-- Users -->
-<g id="node1" class="node">
-<title>Users</title>
-<ellipse fill="none" stroke="black" cx="38.35" cy="-18" rx="38.19" ry="18"/>
-<text text-anchor="middle" x="38.35" y="-14.3" font-family="Times,serif" font-size="14.00">Users</text>
-</g>
-<!-- Proposals -->
-<g id="node2" class="node">
-<title>Proposals</title>
-<ellipse fill="none" stroke="black" cx="221.59" cy="-18" rx="55.79" ry="18"/>
-<text text-anchor="middle" x="221.59" y="-14.3" font-family="Times,serif" font-size="14.00">Proposals</text>
-</g>
-<!-- Users&#45;&gt;Proposals -->
-<g id="edge1" class="edge">
-<title>Users&#45;&gt;Proposals</title>
-<path fill="none" stroke="black" d="M76.9,-18C99.51,-18 128.92,-18 155.24,-18"/>
-<polygon fill="black" stroke="black" points="155.54,-21.5 165.54,-18 155.54,-14.5 155.54,-21.5"/>
-<text text-anchor="middle" x="121.19" y="-21.8" font-family="Times,serif" font-size="14.00">vote on</text>
-</g>
-<!-- Effects -->
-<g id="node3" class="node">
-<title>Effects</title>
-<ellipse fill="none" stroke="black" cx="483.38" cy="-18" rx="42.79" ry="18"/>
-<text text-anchor="middle" x="483.38" y="-14.3" font-family="Times,serif" font-size="14.00">Effects</text>
-</g>
-<!-- Proposals&#45;&gt;Effects -->
-<g id="edge2" class="edge">
-<title>Proposals&#45;&gt;Effects</title>
-<path fill="none" stroke="black" d="M277.68,-18C322.64,-18 385.72,-18 429.94,-18"/>
-<polygon fill="black" stroke="black" points="430.19,-21.5 440.19,-18 430.19,-14.5 430.19,-21.5"/>
-<text text-anchor="middle" x="358.98" y="-21.8" font-family="Times,serif" font-size="14.00">have one or many</text>
-</g>
-<!-- Components -->
-<g id="node4" class="node">
-<title>Components</title>
-<ellipse fill="none" stroke="black" cx="665.17" cy="-18" rx="68.79" ry="18"/>
-<text text-anchor="middle" x="665.17" y="-14.3" font-family="Times,serif" font-size="14.00">Components</text>
-</g>
-<!-- Effects&#45;&gt;Components -->
-<g id="edge3" class="edge">
-<title>Effects&#45;&gt;Components</title>
-<path fill="none" stroke="black" d="M526.53,-18C544.29,-18 565.55,-18 585.99,-18"/>
-<polygon fill="black" stroke="black" points="586.25,-21.5 596.25,-18 586.25,-14.5 586.25,-21.5"/>
-<text text-anchor="middle" x="561.28" y="-21.8" font-family="Times,serif" font-size="14.00">alter</text>
-</g>
-</g>
-</svg>

docs/diagrams/gov-overview.dot

@@ -1,7 +1,9 @@
 digraph {
-  Stakes -> Proposals [label="vote on"]
+  Stakes -> Proposals [label="create and vote on"]
   Proposals -> Effects [label="have"]
+  Admin-> Governor [label="initializes"]
   Governor -> Effects [label="issues GATs to"]
   Users -> Stakes [label="lock GT in"]
   Effects -> Treasury [label="release GT from"]
+  Effects -> Components [label="alter"]
 }

docs/diagrams/gov-overview.svg

@@ -4,80 +4,106 @@
 <!-- Generated by graphviz version 2.49.3 (0)
  -->
 <!-- Pages: 1 -->
-<svg width="262pt" height="392pt"
- viewBox="0.00 0.00 261.95 392.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<svg width="327pt" height="392pt"
+ viewBox="0.00 0.00 327.00 392.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
 <g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 388)">
-<polygon fill="white" stroke="transparent" points="-4,4 -4,-388 257.95,-388 257.95,4 -4,4"/>
+<polygon fill="white" stroke="transparent" points="-4,4 -4,-388 323,-388 323,4 -4,4"/>
 <!-- Stakes -->
 <g id="node1" class="node">
 <title>Stakes</title>
-<ellipse fill="none" stroke="black" cx="181.95" cy="-279" rx="42.49" ry="18"/>
-<text text-anchor="middle" x="181.95" y="-275.3" font-family="Times,serif" font-size="14.00">Stakes</text>
+<ellipse fill="none" stroke="black" cx="186" cy="-279" rx="42.49" ry="18"/>
+<text text-anchor="middle" x="186" y="-275.3" font-family="Times,serif" font-size="14.00">Stakes</text>
 </g>
 <!-- Proposals -->
 <g id="node2" class="node">
 <title>Proposals</title>
-<ellipse fill="none" stroke="black" cx="181.95" cy="-192" rx="55.79" ry="18"/>
-<text text-anchor="middle" x="181.95" y="-188.3" font-family="Times,serif" font-size="14.00">Proposals</text>
+<ellipse fill="none" stroke="black" cx="186" cy="-192" rx="55.79" ry="18"/>
+<text text-anchor="middle" x="186" y="-188.3" font-family="Times,serif" font-size="14.00">Proposals</text>
 </g>
 <!-- Stakes&#45;&gt;Proposals -->
 <g id="edge1" class="edge">
 <title>Stakes&#45;&gt;Proposals</title>
-<path fill="none" stroke="black" d="M181.95,-260.8C181.95,-249.16 181.95,-233.55 181.95,-220.24"/>
-<polygon fill="black" stroke="black" points="185.45,-220.18 181.95,-210.18 178.45,-220.18 185.45,-220.18"/>
-<text text-anchor="middle" x="208.45" y="-231.8" font-family="Times,serif" font-size="14.00">vote on</text>
+<path fill="none" stroke="black" d="M186,-260.8C186,-249.16 186,-233.55 186,-220.24"/>
+<polygon fill="black" stroke="black" points="189.5,-220.18 186,-210.18 182.5,-220.18 189.5,-220.18"/>
+<text text-anchor="middle" x="252.5" y="-231.8" font-family="Times,serif" font-size="14.00">create and vote on</text>
 </g>
 <!-- Effects -->
 <g id="node3" class="node">
 <title>Effects</title>
-<ellipse fill="none" stroke="black" cx="116.95" cy="-105" rx="42.79" ry="18"/>
-<text text-anchor="middle" x="116.95" y="-101.3" font-family="Times,serif" font-size="14.00">Effects</text>
+<ellipse fill="none" stroke="black" cx="121" cy="-105" rx="42.79" ry="18"/>
+<text text-anchor="middle" x="121" y="-101.3" font-family="Times,serif" font-size="14.00">Effects</text>
 </g>
 <!-- Proposals&#45;&gt;Effects -->
 <g id="edge2" class="edge">
 <title>Proposals&#45;&gt;Effects</title>
-<path fill="none" stroke="black" d="M176.2,-173.75C172.31,-163.6 166.5,-150.86 158.95,-141 155.25,-136.17 150.77,-131.57 146.14,-127.38"/>
-<polygon fill="black" stroke="black" points="148.19,-124.54 138.3,-120.76 143.68,-129.88 148.19,-124.54"/>
-<text text-anchor="middle" x="183.95" y="-144.8" font-family="Times,serif" font-size="14.00">have</text>
+<path fill="none" stroke="black" d="M180.25,-173.75C176.36,-163.6 170.55,-150.86 163,-141 159.3,-136.17 154.82,-131.57 150.19,-127.38"/>
+<polygon fill="black" stroke="black" points="152.24,-124.54 142.35,-120.76 147.73,-129.88 152.24,-124.54"/>
+<text text-anchor="middle" x="188" y="-144.8" font-family="Times,serif" font-size="14.00">have</text>
 </g>
 <!-- Treasury -->
-<g id="node6" class="node">
+<g id="node7" class="node">
 <title>Treasury</title>
-<ellipse fill="none" stroke="black" cx="116.95" cy="-18" rx="51.99" ry="18"/>
-<text text-anchor="middle" x="116.95" y="-14.3" font-family="Times,serif" font-size="14.00">Treasury</text>
+<ellipse fill="none" stroke="black" cx="52" cy="-18" rx="51.99" ry="18"/>
+<text text-anchor="middle" x="52" y="-14.3" font-family="Times,serif" font-size="14.00">Treasury</text>
 </g>
 <!-- Effects&#45;&gt;Treasury -->
-<g id="edge5" class="edge">
+<g id="edge6" class="edge">
 <title>Effects&#45;&gt;Treasury</title>
-<path fill="none" stroke="black" d="M116.95,-86.8C116.95,-75.16 116.95,-59.55 116.95,-46.24"/>
-<polygon fill="black" stroke="black" points="120.45,-46.18 116.95,-36.18 113.45,-46.18 120.45,-46.18"/>
-<text text-anchor="middle" x="174.45" y="-57.8" font-family="Times,serif" font-size="14.00">release GT from</text>
+<path fill="none" stroke="black" d="M86.61,-94.14C74.21,-88.77 61.44,-80.75 54,-69 49.73,-62.26 48.26,-53.93 48.14,-46.01"/>
+<polygon fill="black" stroke="black" points="51.64,-46.17 48.63,-36.01 44.65,-45.83 51.64,-46.17"/>
+<text text-anchor="middle" x="111.5" y="-57.8" font-family="Times,serif" font-size="14.00">release GT from</text>
+</g>
+<!-- Components -->
+<g id="node8" class="node">
+<title>Components</title>
+<ellipse fill="none" stroke="black" cx="191" cy="-18" rx="68.79" ry="18"/>
+<text text-anchor="middle" x="191" y="-14.3" font-family="Times,serif" font-size="14.00">Components</text>
+</g>
+<!-- Effects&#45;&gt;Components -->
+<g id="edge7" class="edge">
+<title>Effects&#45;&gt;Components</title>
+<path fill="none" stroke="black" d="M145.54,-89.8C153.79,-84.13 162.53,-77.03 169,-69 174.58,-62.07 179.02,-53.5 182.41,-45.42"/>
+<polygon fill="black" stroke="black" points="185.73,-46.55 186.04,-35.96 179.19,-44.05 185.73,-46.55"/>
+<text text-anchor="middle" x="194" y="-57.8" font-family="Times,serif" font-size="14.00">alter</text>
+</g>
+<!-- Admin -->
+<g id="node4" class="node">
+<title>Admin</title>
+<ellipse fill="none" stroke="black" cx="58" cy="-279" rx="40.09" ry="18"/>
+<text text-anchor="middle" x="58" y="-275.3" font-family="Times,serif" font-size="14.00">Admin</text>
 </g>
 <!-- Governor -->
-<g id="node4" class="node">
+<g id="node5" class="node">
 <title>Governor</title>
-<ellipse fill="none" stroke="black" cx="53.95" cy="-192" rx="53.89" ry="18"/>
-<text text-anchor="middle" x="53.95" y="-188.3" font-family="Times,serif" font-size="14.00">Governor</text>
+<ellipse fill="none" stroke="black" cx="58" cy="-192" rx="53.89" ry="18"/>
+<text text-anchor="middle" x="58" y="-188.3" font-family="Times,serif" font-size="14.00">Governor</text>
+</g>
+<!-- Admin&#45;&gt;Governor -->
+<g id="edge3" class="edge">
+<title>Admin&#45;&gt;Governor</title>
+<path fill="none" stroke="black" d="M58,-260.8C58,-249.16 58,-233.55 58,-220.24"/>
+<polygon fill="black" stroke="black" points="61.5,-220.18 58,-210.18 54.5,-220.18 61.5,-220.18"/>
+<text text-anchor="middle" x="93" y="-231.8" font-family="Times,serif" font-size="14.00">initializes</text>
 </g>
 <!-- Governor&#45;&gt;Effects -->
-<g id="edge3" class="edge">
+<g id="edge4" class="edge">
 <title>Governor&#45;&gt;Effects</title>
-<path fill="none" stroke="black" d="M50.23,-173.63C48.99,-163.43 49.16,-150.69 54.95,-141 59.79,-132.9 67.26,-126.51 75.36,-121.54"/>
-<polygon fill="black" stroke="black" points="77.18,-124.54 84.3,-116.69 73.84,-118.38 77.18,-124.54"/>
-<text text-anchor="middle" x="106.95" y="-144.8" font-family="Times,serif" font-size="14.00">issues GATs to</text>
+<path fill="none" stroke="black" d="M54.28,-173.63C53.04,-163.43 53.21,-150.69 59,-141 63.84,-132.9 71.31,-126.51 79.41,-121.54"/>
+<polygon fill="black" stroke="black" points="81.23,-124.54 88.35,-116.69 77.89,-118.38 81.23,-124.54"/>
+<text text-anchor="middle" x="111" y="-144.8" font-family="Times,serif" font-size="14.00">issues GATs to</text>
 </g>
 <!-- Users -->
-<g id="node5" class="node">
+<g id="node6" class="node">
 <title>Users</title>
-<ellipse fill="none" stroke="black" cx="181.95" cy="-366" rx="38.19" ry="18"/>
-<text text-anchor="middle" x="181.95" y="-362.3" font-family="Times,serif" font-size="14.00">Users</text>
+<ellipse fill="none" stroke="black" cx="186" cy="-366" rx="38.19" ry="18"/>
+<text text-anchor="middle" x="186" y="-362.3" font-family="Times,serif" font-size="14.00">Users</text>
 </g>
 <!-- Users&#45;&gt;Stakes -->
-<g id="edge4" class="edge">
+<g id="edge5" class="edge">
 <title>Users&#45;&gt;Stakes</title>
-<path fill="none" stroke="black" d="M181.95,-347.8C181.95,-336.16 181.95,-320.55 181.95,-307.24"/>
-<polygon fill="black" stroke="black" points="185.45,-307.18 181.95,-297.18 178.45,-307.18 185.45,-307.18"/>
-<text text-anchor="middle" x="217.95" y="-318.8" font-family="Times,serif" font-size="14.00">lock GT in</text>
+<path fill="none" stroke="black" d="M186,-347.8C186,-336.16 186,-320.55 186,-307.24"/>
+<polygon fill="black" stroke="black" points="189.5,-307.18 186,-297.18 182.5,-307.18 189.5,-307.18"/>
+<text text-anchor="middle" x="222" y="-318.8" font-family="Times,serif" font-size="14.00">lock GT in</text>
 </g>
 </g>
 </svg>

docs/meta/README.md

@@ -1,3 +0,0 @@
-# Docs meta
-
-This folder includes notes to assist in the writing of documentation. Those not involved with spec writing have no need for these files.

docs/meta/status-format.md

@@ -1,119 +0,0 @@
-# Spec status format
-
-This document specifies a format used to denote the 'status' of a spec document.
-
-## Overview
-
-Each specification document should be headed by a simple table outlining aspects of its status in relation to:
-
--   Authorship: who has contributed to it?
--   Ownership: who is responsible for it?
--   Implementation(s): where is it used?
--   Completeness: is it done yet?
-
-This format should be used at the start of any documentation that may be considered a _technical specification_, with a related implementation. 
-
-## Format
-
-The format is as follows, with {substitutions} in curly braces.
-
-| Specification | Implementation | Last revision |
-|:-------------:|:--------------:|:-------------:|
-| {status}      | {status}       | {version} {date} |
-
---------------------
-
-**Specification ownership:** {[Spec owner]}
-
-**Authors**: 
- -   {[Spec owner]}
- -   {[Author]}
-
-**Implementation ownership:** {[Impl owner]}
- 
-**Current status**:
- 
-{Short description of status regarding __both__ specification and implementation}.
-
-[Spec owner]: https://genrandom.com/cats/
-[Author]: https://genrandom.com/cats/
-[Impl owner]: https://genrandom.com/cats/
-
-```markdown
-| Specification | Implementation | Last Revision |
-|:-------------:|:--------------:|:-------------:|
-| {status}      | {status}       | {version}, {date} |
-
---------------------
-
-**Specification ownership:** [{owner name}]
-
-**Authors**: 
- -   [{owner name}]
- -   [{author name}]
-
-
-**Implementation ownership:** [{impl owner name}]
- 
-**Current status**:
- 
-{Short description of status}
-
-[{owner name}]: {github url}
-[{author name}]: {github url}
-[{impl owner name}]: {github url}
-
---------------------
-```
-
-### Specification/Implementation status
-
-The 'Specification' and 'Implementation' status should be one of the following:
-
--   `WIP`: Work In Progress, currently incomplete, pending current or future work by the current owner or a future owner.
--   `Draft`: Complete but pending further evaluation or changes to be accounted for in the future.
--   `Final`: Complete and finalised to some degree of certainty.
-
-### Last revision
-
--   version - An optional version/revision number for the spec document.
--   date - date the document was last updated in [ISO 8601 format](https://www.wikiwand.com/en/ISO_8601#/Calendar_dates) (YYYY-MM-DD).
-
-### Authors
-
-The authors and contributors of the spec document.
-
-### Specification ownership
-
-The person currently, or most recently tasked with writing and maintaining the spec document.
-
-### Implementation ownership
-
-The person currently or most recently tasked with the implementation of the features described in the document.
-
--   For individual features, this will be the person most recently assigned to related GitHub issues.
--   For broader sections, this will be a person leading the implementation efforts for the particular system.
-
-## Example
-
-| Specification | Implementation | Last Revision |
-|:-------------:|:--------------:|:-------------:|
-| WIP   | Draft     | 0.1 2022-01-31 |
-
---------------------
-
-**Specification ownership:** [Jack Hodgkinson]
-
-**Authors**: 
- -   [Jack Hodgkinson]
- -   [Emily Martins]
-
-**Implementation ownership:** [Emily Martins]
- 
-**Current status**:
- 
-Draft completed in project repo. Spec needs revisiting to address issues outlined in #42. Section on staking pool behaviour is out-dated. 
-
-[Jack Hodgkinson]: https://github.com/jhodgdev
-[Emily Martins]: https://github.com/emiflake
-***

docs/meta/style-guide.md

@@ -1,52 +0,0 @@
-# Agora docs style guide
-
-This document includes a couple of notes on how Agora documentation should be written and formatted.
-
-## British/American spelling and grammatical differences
-
-The difference between British and American English is wider than a lot of people presume. Authors are permitted to use whichever of the two they learned and therefore feel more comfortable with. The only exception to this is when writing changes that would result in a 'mixing' of styles e.g. having 'color' in a sentence and 'colour' in the next. In this instance please alter your use of the language to maintain consistency.
-
-## Capitalised words
-
-The following words should always in the forms below:
-
--   Agora
--   Liqwid
--   LiqwidX
--   Nix
--   NixOS
--   Plutus
--   Plutarch
-
-Sensible exceptions naturally exist, including referencing shell commands (`nix-shell`) or code:
-
-```haskell
-plutarchTerm :: Term s a 
-plutarchTerm = ...
-```
-
-## Upper-case terms
-
-The following terms should always be rendered in all capital letters:
-
--   UTXO
--   EUTXO
-
-## Lower-case words
-
-The following words should always be rendered lower-case (unless used at the beginning of a sentence):
-
--   governance
-
-## ADA, Ada, ada
-
-Cardano's native token suffers from a frustrating variety of acceptable forms. Reputable sources can be found using all three variants listed in the header. As such, no usage shall be mandated with two caveats:
-
-1.  Whilst the name of the currency is subject to variance, its 'symbol' is unambiguously 'ADA'. Therefore when talking about amounts e.g. 'Trillian deposits 100ADA', use 'ADA'.
-2.  Exercise _reasonable consistency_. The use of an 'Ada' at the beginning of the document and an 'ada' 3000 words later is not something worth losing sleep over. Inconsistency within paragraphs or (gasp!) _sentences_ should always be avoided.
-
-## Avoid
-
-The following practices should be avoided:
-
--   The use of '&' apart from in proper nouns such as AT\&T.

flake.nix

@@ -1,109 +1,84 @@
 {
   description = "agora";
 
-  inputs = {
-    nixpkgs.follows = "plutarch/nixpkgs";
-    nixpkgs-latest.url = "github:NixOS/nixpkgs?rev=cf63df0364f67848083ff75bc8ac9b7ca7aa5a01";
-    # temporary fix for nix versions that have the transitive follows bug
-    # see https://github.com/NixOS/nix/issues/6013
-    nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
-
-    haskell-nix-extra-hackage.follows = "plutarch/haskell-nix-extra-hackage";
-    haskell-nix.follows = "plutarch/haskell-nix";
-    iohk-nix.follows = "plutarch/iohk-nix";
-    haskell-language-server.follows = "plutarch/haskell-language-server";
-
-    # Plutarch and its friends
-    plutarch = {
-      url = "github:Plutonomicon/plutarch-plutus?ref=staging";
-
-      inputs.emanote.follows =
-        "plutarch/haskell-nix/nixpkgs-unstable";
-      inputs.nixpkgs.follows =
-        "plutarch/haskell-nix/nixpkgs-unstable";
-    };
-
-    plutarch-numeric.url =
-      "github:Liqwid-Labs/plutarch-numeric?ref=main";
-    plutarch-safe-money.url =
-      "github:Liqwid-Labs/plutarch-safe-money?ref=main";
-    liqwid-plutarch-extra.url =
-      "github:Liqwid-Labs/liqwid-plutarch-extra?ref=plutus-v1";
-    plutarch-quickcheck.url =
-      "github:liqwid-labs/plutarch-quickcheck?ref=staging";
-    plutarch-context-builder.url =
-      "github:Liqwid-Labs/plutarch-context-builder?ref=plutus-v1";
-    plutarch-script-export.url =
-      "github:Liqwid-Labs/plutarch-script-export?ref=main";
-
-    liqwid-nix.url = "github:Liqwid-Labs/liqwid-nix?ref=main";
+  nixConfig = {
+    extra-experimental-features = [ "nix-command" "flakes" "ca-derivations" ];
+    extra-substituters = [ "https://cache.iog.io" "https://mlabs.cachix.org" ];
+    extra-trusted-public-keys = [ "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" ];
+    allow-import-from-derivation = "true";
+    max-jobs = "auto";
+    auto-optimise-store = "true";
   };
 
-  outputs = inputs@{ liqwid-nix, ... }:
-    let
-      benchCheckOverlay = self: super: {
-        toFlake =
-          let
-            inherit (self) inputs perSystem pkgsFor';
-            flake = super.toFlake or { };
-            name = "benchCheck";
-          in
-          flake // {
-            checks = perSystem (system:
-              flake.checks.${system} // {
-                ${name} =
-                  let
-                    pkgs' = pkgsFor' system;
-                    bench = flake.packages.${system}."agora:bench:agora-bench";
-                  in
-                  pkgs'.runCommand name
-                    {
-                      nativeBuildInputs = [ pkgs'.diffutils ];
-                    } ''
-                    export LC_CTYPE=C.UTF-8
-                    export LC_ALL=C.UTF-8
-                    export LANG=C.UTF-8
-                    cd ${inputs.self}
-                    ${bench}/bin/agora-bench | diff bench.csv - \
-                      || (echo "bench.csv is outdated"; exit 1)
-                    mkdir "$out"
-                  '';
-              });
+  inputs = {
+    nixpkgs.follows = "liqwid-nix/nixpkgs";
+    nixpkgs-latest.url = "github:NixOS/nixpkgs";
+
+    liqwid-nix = {
+      url = "github:Liqwid-Labs/liqwid-nix/v2.7.2";
+      inputs.nixpkgs-latest.follows = "nixpkgs-latest";
+    };
+
+    liqwid-libs.url =
+      "github:Liqwid-Labs/liqwid-libs";
+  };
+
+  outputs = inputs@{ self, flake-parts, ... }:
+    flake-parts.lib.mkFlake { inherit inputs; } {
+      imports = [
+        inputs.liqwid-nix.flakeModule
+      ];
+      systems = [ "x86_64-linux" "aarch64-darwin" "x86_64-darwin" "aarch64-linux" ];
+      perSystem = { config, self', inputs', pkgs, system, ... }:
+        let
+          pkgs = import inputs.nixpkgs-latest { inherit system; };
+        in
+        {
+          onchain.default = {
+            src = ./.;
+            ghc.version = "ghc925";
+            fourmolu.package = pkgs.haskell.packages.ghc943.fourmolu_0_10_1_0;
+            hlint = { };
+            cabalFmt = { };
+            hasktags = { };
+            applyRefact = { };
+            shell = { };
+            hoogleImage.enable = false;
+            enableBuildChecks = true;
+            extraHackageDeps = [
+              "${inputs.liqwid-libs}/plutarch-quickcheck"
+              "${inputs.liqwid-libs}/plutarch-context-builder"
+              "${inputs.liqwid-libs}/liqwid-plutarch-extra"
+              "${inputs.liqwid-libs}/liqwid-script-export"
+              "${inputs.liqwid-libs.inputs.ply}/ply-core"
+              "${inputs.liqwid-libs.inputs.ply}/ply-plutarch"
+            ];
           };
-      };
-    in
-    (liqwid-nix.buildProject
-      {
-        inherit inputs;
-        src = ./.;
-      }
-      [
-        liqwid-nix.haskellProject
-        liqwid-nix.plutarchProject
-        (liqwid-nix.addDependencies [
-          "${inputs.plutarch-numeric}"
-          "${inputs.plutarch-safe-money}"
-          "${inputs.plutarch-quickcheck}"
-          "${inputs.plutarch-context-builder}"
-          "${inputs.liqwid-plutarch-extra}"
-          "${inputs.plutarch-script-export}"
-        ])
-        (liqwid-nix.enableFormatCheck [
-          "-XQuasiQuotes"
-          "-XTemplateHaskell"
-          "-XTypeApplications"
-          "-XImportQualifiedPost"
-          "-XPatternSynonyms"
-          "-XOverloadedRecordDot"
-        ])
-        liqwid-nix.enableLintCheck
-        liqwid-nix.enableCabalFormatCheck
-        liqwid-nix.enableNixFormatCheck
-        liqwid-nix.addBuildChecks
-        (liqwid-nix.addCommandLineTools (pkgs: _: [
-          pkgs.haskellPackages.hasktags
-        ]))
-        benchCheckOverlay
-      ]
-    ).toFlake;
+          ci.required = [ "all_onchain" ];
+          packages.export =
+            pkgs.stdenv.mkDerivation {
+              name = "export";
+              src = ./.;
+              buildInput = [
+                self'.packages."agora:exe:agora-scripts"
+              ];
+              buildPhase = ''
+                export PATH=$PATH:${self'.packages."agora:exe:agora-scripts"}/bin
+                agora-scripts file --builder raw
+                agora-scripts file --builder rawDebug
+              '';
+              installPhase = ''
+                NAME=${if self ? rev then self.shortRev else "dirty"}
+                mkdir $out
+                cp raw.json $out/agora-"$NAME".json
+                cp rawDebug.json $out/agora-debug-"$NAME".json
+              '';
+            };
+        };
+
+      flake.hydraJobs.x86_64-linux = (
+        self.checks.x86_64-linux
+        // self.packages.x86_64-linux
+      );
+    };
 }