diff --git a/Makefile b/Makefile index 887a617..18a40d7 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that. SHELL := /bin/sh -.PHONY: hoogle format haddock usage tag lint ps_bridge +.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check lint ps_bridge usage: @echo "usage: make [OPTIONS]" @@ -11,6 +11,9 @@ usage: @echo " format -- Format the project" @echo " haddock -- Generate Haddock docs for project" @echo " tag -- Generate CTAGS and ETAGS files for project" + @echo " format_haskell -- Format haskell stuff, including source code and cabal files" + @echo " format_nix -- Format *.nix files only" + @echo " format_check -- Check if all haskell stuff have been formatted correctly" @echo " lint -- Get hlint suggestions for project" @echo " ps_bridge -- Generate purescript bridge files" diff --git a/agora-purescript-bridge/src/Agora/Governor.purs b/agora-purescript-bridge/src/Agora/Governor.purs index e8f5384..29172a1 100644 --- a/agora-purescript-bridge/src/Agora/Governor.purs +++ b/agora-purescript-bridge/src/Agora/Governor.purs @@ -4,6 +4,7 @@ module Agora.Governor where import Prelude import Agora.Proposal (ProposalId, ProposalThresholds) +import Agora.SafeMoney (GTTag) import Data.Bounded.Generic (genericBottom, genericTop) import Data.Enum (class Enum) import Data.Enum.Generic (genericPred, genericSucc) @@ -13,6 +14,10 @@ import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype) +import Data.Tagged (Tagged) +import GHC.Num.Integer (Integer) +import Plutus.V1.Ledger.Tx (TxOutRef) +import Plutus.V1.Ledger.Value (AssetClass) import Type.Proxy (Proxy(Proxy)) newtype GovernorDatum = GovernorDatum @@ -34,6 +39,7 @@ _GovernorDatum = _Newtype data GovernorRedeemer = CreateProposal | MintGATs + | MutateGovernor derive instance Generic GovernorRedeemer _ @@ -57,21 +63,24 @@ _MintGATs = prism' (const MintGATs) case _ of MintGATs -> Just unit _ -> Nothing +_MutateGovernor :: Prism' GovernorRedeemer Unit +_MutateGovernor = prism' (const MutateGovernor) case _ of + MutateGovernor -> Just unit + _ -> Nothing + -------------------------------------------------------------------------------- -data Governor = Governor +newtype Governor = Governor + { gstOutRef :: TxOutRef + , gtClassRef :: Tagged GTTag AssetClass + , maximumCosigners :: Integer + } derive instance Generic Governor _ -instance Enum Governor where - succ = genericSucc - pred = genericPred - -instance Bounded Governor where - bottom = genericBottom - top = genericTop +derive instance Newtype Governor _ -------------------------------------------------------------------------------- -_Governor :: Iso' Governor Unit -_Governor = iso (const unit) (const Governor) +_Governor :: Iso' Governor {gstOutRef :: TxOutRef, gtClassRef :: Tagged GTTag AssetClass, maximumCosigners :: Integer} +_Governor = _Newtype diff --git a/agora-purescript-bridge/src/Agora/Proposal.purs b/agora-purescript-bridge/src/Agora/Proposal.purs index 317987c..416545e 100644 --- a/agora-purescript-bridge/src/Agora/Proposal.purs +++ b/agora-purescript-bridge/src/Agora/Proposal.purs @@ -14,7 +14,6 @@ import Data.Lens.Record (prop) import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype) import Data.Tagged (Tagged) -import Data.Tuple (Tuple) import GHC.Num.Integer (Integer) import Plutus.V1.Ledger.Crypto (PubKeyHash) import Plutus.V1.Ledger.Scripts (DatumHash, ValidatorHash) @@ -120,7 +119,7 @@ _ProposalVotes = _Newtype newtype ProposalDatum = ProposalDatum { proposalId :: ProposalId - , effects :: Map ResultTag (Array (Tuple ValidatorHash DatumHash)) + , effects :: Map ResultTag (Map ValidatorHash DatumHash) , status :: ProposalStatus , cosigners :: Array PubKeyHash , thresholds :: ProposalThresholds @@ -133,7 +132,7 @@ derive instance Newtype ProposalDatum _ -------------------------------------------------------------------------------- -_ProposalDatum :: Iso' ProposalDatum {proposalId :: ProposalId, effects :: Map ResultTag (Array (Tuple ValidatorHash DatumHash)), status :: ProposalStatus, cosigners :: Array PubKeyHash, thresholds :: ProposalThresholds, votes :: ProposalVotes} +_ProposalDatum :: Iso' ProposalDatum {proposalId :: ProposalId, effects :: Map ResultTag (Map ValidatorHash DatumHash), status :: ProposalStatus, cosigners :: Array PubKeyHash, thresholds :: ProposalThresholds, votes :: ProposalVotes} _ProposalDatum = _Newtype -------------------------------------------------------------------------------- diff --git a/agora-sample/Sample/Governor.hs b/agora-sample/Sample/Governor.hs new file mode 100644 index 0000000..ff5f0bf --- /dev/null +++ b/agora-sample/Sample/Governor.hs @@ -0,0 +1,619 @@ +{- | +Module : Spec.Sample.Governor +Maintainer : connor@mlabs.city +Description: Sample based testing for Governor utxos + +This module tests primarily the happy path for Governor interactions +-} +module Sample.Governor ( + createProposal, + mutateState, + mintGATs, + mintGST, +) where + +-------------------------------------------------------------------------------- + +import Plutarch.Api.V1 (mkValidator, validatorHash) +import Plutarch.SafeMoney.Tagged + +-------------------------------------------------------------------------------- + +import Plutus.V1.Ledger.Address (scriptHashAddress) +import Plutus.V1.Ledger.Api ( + Address (..), + Credential (ScriptCredential), + Datum (..), + ScriptContext (..), + ScriptPurpose (Minting, Spending), + ToData (toBuiltinData), + TokenName (..), + TxInInfo (TxInInfo), + TxInfo (..), + TxOut (..), + TxOutRef (..), + Validator, + ValidatorHash (..), + ) +import Plutus.V1.Ledger.Interval qualified as Interval +import Plutus.V1.Ledger.Scripts (unitDatum) +import Plutus.V1.Ledger.Value ( + AssetClass (..), + ) +import Plutus.V1.Ledger.Value qualified as Value +import PlutusTx.AssocMap qualified as AssocMap + +-------------------------------------------------------------------------------- + +import Agora.Effect.NoOp (noOpValidator) +import Agora.Governor (GovernorDatum (..), getNextProposalId) +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (..), + ProposalStatus (..), + ProposalVotes (..), + ResultTag (..), + emptyVotesFor, + ) +import Agora.Proposal qualified as P +import Agora.Stake ( + ProposalLock (..), + Stake (..), + StakeDatum (..), + ) + +-------------------------------------------------------------------------------- + +import Sample.Shared ( + authorityTokenSymbol, + defaultProposalThresholds, + govAssetClass, + govSymbol, + govValidatorAddress, + gstUTXORef, + minAda, + proposalPolicySymbol, + proposalValidatorAddress, + signer, + signer2, + stake, + stakeAddress, + stakeAssetClass, + ) +import Test.Util (datumPair, toDatumHash) + +-------------------------------------------------------------------------------- + +{- | A valid 'ScriptContext' for minting GST. + + - Only the minting policy will be ran in the transaction. + - An arbitrary UTXO is spent to create the token. + + - We call this the "witness" UTXO. + - This UTXO is referenced in the 'Agora.Governor.Governor' parameter + - The minting policy should only be ran once its life time, + cause the GST cannot be minted twice or burnt. + + - The output UTXO must carry a valid 'GovernorDatum'. + - It's worth noticing that the transaction should send the GST to the governor validator, + but unfortunately we can't check it in the policy. The GST will stay at the address of + the governor validator forever once the token is under control of the said validator. + + TODO: tag the output UTXO with the target address. +-} +mintGST :: ScriptContext +mintGST = + let gst = Value.assetClassValue govAssetClass 1 + + --- + + governorOutputDatum' :: GovernorDatum + governorOutputDatum' = + GovernorDatum + { proposalThresholds = defaultProposalThresholds + , nextProposalId = ProposalId 0 + } + governorOutputDatum :: Datum + governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' + governorOutput :: TxOut + governorOutput = + TxOut + { txOutAddress = govValidatorAddress + , txOutValue = gst <> minAda + , txOutDatumHash = Just $ toDatumHash governorOutputDatum + } + + --- + + witness :: ValidatorHash + witness = "a926a9a72a0963f428e3252caa8354e655603996fb8892d6b8323fd072345924" + witnessAddress :: Address + witnessAddress = Address (ScriptCredential witness) Nothing + + --- + + -- The witness UTXO must be consumed. + witnessInput :: TxOut + witnessInput = + TxOut + { txOutAddress = witnessAddress + , txOutValue = mempty + , txOutDatumHash = Nothing + } + initialSpend :: TxInInfo + initialSpend = TxInInfo gstUTXORef witnessInput + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ initialSpend + ] + , txInfoOutputs = [governorOutput] + , -- Some ada to cover the transaction fee + txInfoFee = Value.singleton "" "" 2 + , -- Exactly one GST is minted + txInfoMint = gst + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [datumPair governorOutputDatum] + , txInfoId = "90906d3e6b4d6dec2e747dcdd9617940ea8358164c7244694cfa39dec18bd9d4" + } + , scriptContextPurpose = Minting govSymbol + } + +{- | A valid script context to create a proposal. + + Three component will run in the transaction: + TODO: mention redeemers + + - Governor validator + - Stake validator + - Proposal policy + + The components will ensure: + + - The governor state UTXO is spent + + - A new UTXO is paid back to governor validator, which carries the GST. + - The proposal id in the state datum is advanced. + + - A new UTXO is sent to the proposal validator + + - The UTXO contains a newly minted proposal state token. + - It also carries a legal proposal state datum, whose status is set to 'Agora.Proposal.Draft'. + + - A stake is spent to create a proposal + + - The stake owner must sign the transaction. + - The output stake must paid back to the stake validator. + - The output stake is locked by the newly created proposal. +-} +createProposal :: ScriptContext +createProposal = + let pst = Value.singleton proposalPolicySymbol "" 1 + gst = Value.assetClassValue govAssetClass 1 + sst = Value.assetClassValue stakeAssetClass 1 + stackedGTs = 424242424242 + thisProposalId = ProposalId 0 + + --- + + governorInputDatum' :: GovernorDatum + governorInputDatum' = + GovernorDatum + { proposalThresholds = defaultProposalThresholds + , nextProposalId = thisProposalId + } + governorInputDatum :: Datum + governorInputDatum = Datum $ toBuiltinData governorInputDatum' + governorInput :: TxOut + governorInput = + TxOut + { txOutAddress = govValidatorAddress + , txOutValue = gst + , txOutDatumHash = Just $ toDatumHash governorInputDatum + } + + --- + + effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + proposalDatum :: Datum + proposalDatum = + Datum + ( toBuiltinData $ + ProposalDatum + { P.proposalId = ProposalId 0 + , effects = effects + , status = Draft + , cosigners = [signer] + , thresholds = defaultProposalThresholds + , votes = emptyVotesFor effects + } + ) + proposalOutput :: TxOut + proposalOutput = + TxOut + { txOutAddress = proposalValidatorAddress + , txOutValue = pst <> minAda + , txOutDatumHash = Just (toDatumHash proposalDatum) + } + + --- + + stakeInputDatum' :: StakeDatum + stakeInputDatum' = + StakeDatum + { stakedAmount = Tagged stackedGTs + , owner = signer + , lockedBy = [] + } + stakeInputDatum :: Datum + stakeInputDatum = Datum $ toBuiltinData stakeInputDatum' + stakeInput :: TxOut + stakeInput = + TxOut + { txOutAddress = stakeAddress + , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs + , txOutDatumHash = Just (toDatumHash stakeInputDatum) + } + + --- + governorOutputDatum' :: GovernorDatum + governorOutputDatum' = governorInputDatum' {nextProposalId = getNextProposalId thisProposalId} + governorOutputDatum :: Datum + governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' + governorOutput :: TxOut + governorOutput = + governorInput + { txOutDatumHash = Just $ toDatumHash governorOutputDatum + , txOutValue = gst <> minAda + } + + --- + + proposalLocks :: [ProposalLock] + proposalLocks = + [ ProposalLock (ResultTag 0) thisProposalId + , ProposalLock (ResultTag 1) thisProposalId + ] + stakeOutputDatum' :: StakeDatum + stakeOutputDatum' = stakeInputDatum' {lockedBy = proposalLocks} + stakeOutputDatum :: Datum + stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum' + stakeOutput :: TxOut + stakeOutput = + stakeInput + { txOutDatumHash = Just $ toDatumHash stakeOutputDatum + , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs <> minAda + } + + --- + ownInputRef :: TxOutRef + ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo + ownInputRef + governorInput + , TxInInfo + (TxOutRef "4262bbd0b3fc926b74eaa8abab5def6ce5e6b94f19cf221c02a16e7da8cd470f" 1) + stakeInput + ] + , txInfoOutputs = [proposalOutput, governorOutput, stakeOutput] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = pst + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = + datumPair + <$> [ governorInputDatum + , governorOutputDatum + , proposalDatum + , stakeInputDatum + , stakeOutputDatum + ] + , txInfoId = "1ffb9669335c908d9a4774a4bf7aa7bfafec91d015249b4138bc83fde4a3330a" + } + , scriptContextPurpose = Spending ownInputRef + } + +{- This script context should be a valid transaction for minting authority for the effect scrips. + + The following components will run: + + - Governor validator + - Authority policy + - Proposal validator + + There should be only one proposal the transaction. + The validity of the proposal will be checked: + + - It's in 'Agora.Proposal.Locked' state. + - It has a 'winner' effect group, meaning that the votes meet the requirements. + + The system will ensure that for every effect scrips in said effect group, + a newly minted GAT is sent to the corresponding effect, and properly tagged. +-} +mintGATs :: ScriptContext +mintGATs = + let pst = Value.singleton proposalPolicySymbol "" 1 + gst = Value.assetClassValue govAssetClass 1 + gat = Value.assetClassValue atAssetClass 1 + + --- + + mockEffect :: Validator + mockEffect = mkValidator $ noOpValidator "" + mockEffectHash :: ValidatorHash + mockEffectHash = validatorHash mockEffect + mockEffectAddress :: Address + mockEffectAddress = scriptHashAddress mockEffectHash + mockEffectOutputDatum :: Datum + mockEffectOutputDatum = unitDatum + atTokenName :: TokenName + atTokenName = TokenName hash + where + ValidatorHash hash = mockEffectHash + atAssetClass :: AssetClass + atAssetClass = AssetClass (authorityTokenSymbol, atTokenName) + + --- + + governorInputDatum' :: GovernorDatum + governorInputDatum' = + GovernorDatum + { proposalThresholds = defaultProposalThresholds + , nextProposalId = ProposalId 5 + } + governorInputDatum :: Datum + governorInputDatum = Datum $ toBuiltinData governorInputDatum' + governorInput :: TxOut + governorInput = + TxOut + { txOutAddress = govValidatorAddress + , txOutValue = gst + , txOutDatumHash = Just $ toDatumHash governorInputDatum + } + + --- + + effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.singleton mockEffectHash $ toDatumHash mockEffectOutputDatum) + ] + proposalVotes :: ProposalVotes + proposalVotes = + ProposalVotes $ + AssocMap.fromList + [ (ResultTag 0, 100) + , (ResultTag 1, 2000) -- The winner + ] + proposalInputDatum' :: ProposalDatum + proposalInputDatum' = + ProposalDatum + { P.proposalId = ProposalId 0 + , effects = effects + , status = Locked + , cosigners = [signer, signer2] + , thresholds = defaultProposalThresholds + , votes = proposalVotes + } + proposalInputDatum :: Datum + proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' + proposalInput :: TxOut + proposalInput = + TxOut + { txOutAddress = proposalValidatorAddress + , txOutValue = pst + , txOutDatumHash = Just (toDatumHash proposalInputDatum) + } + + --- + + governorOutputDatum' :: GovernorDatum + governorOutputDatum' = governorInputDatum' + governorOutputDatum :: Datum + governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' + governorOutput :: TxOut + governorOutput = + governorInput + { txOutDatumHash = Just $ toDatumHash governorOutputDatum + , txOutValue = gst <> minAda + } + + --- + + proposalOutputDatum' :: ProposalDatum + proposalOutputDatum' = proposalInputDatum' {status = Finished} + proposalOutputDatum :: Datum + proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum' + proposalOutput :: TxOut + proposalOutput = + proposalInput + { txOutDatumHash = Just $ toDatumHash proposalOutputDatum + , txOutValue = pst <> minAda + } + + -- + + mockEffectOutput :: TxOut + mockEffectOutput = + TxOut + { txOutAddress = mockEffectAddress + , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum + , txOutValue = gat <> minAda + } + + -- + + ownInputRef :: TxOutRef + ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo ownInputRef governorInput + , TxInInfo + (TxOutRef "11b2162f267614b803761032b6333040fc61478ae788c088614ee9487ab0c1b7" 1) + proposalInput + ] + , txInfoOutputs = + [ governorOutput + , proposalOutput + , mockEffectOutput + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = gat + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer, signer2] + , txInfoData = + datumPair + <$> [ governorInputDatum + , governorOutputDatum + , proposalInputDatum + , proposalOutputDatum + , mockEffectOutputDatum + ] + , txInfoId = "ff755f613c1f7487dfbf231325c67f481f7a97e9faf4d8b09ad41176fd65cbe7" + } + , scriptContextPurpose = Spending ownInputRef + } + +{- | A valid script context for changing the state datum of the governor. + + In this case, the following components will run: + + * Governor validator + * Effect script + + The effect script should carry an valid tagged authority token, + and said token will be burnt in the transaction. We use 'noOpValidator' + here as a mock effect, so no actual change is done to the governor state. + TODO: use 'mutateGovernorEffect' as the mock effect in the future. + + The governor will ensure the new governor state is valid. +-} +mutateState :: ScriptContext +mutateState = + let gst = Value.assetClassValue govAssetClass 1 + gat = Value.assetClassValue atAssetClass 1 + burntGAT = Value.assetClassValue atAssetClass (-1) + + --- + + -- TODO: Use the *real* effect, see https://github.com/Liqwid-Labs/agora/pull/62 + + mockEffect :: Validator + mockEffect = mkValidator $ noOpValidator "" + mockEffectHash :: ValidatorHash + mockEffectHash = validatorHash mockEffect + mockEffectAddress :: Address + mockEffectAddress = scriptHashAddress mockEffectHash + atTokenName :: TokenName + atTokenName = TokenName hash + where + ValidatorHash hash = mockEffectHash + atAssetClass :: AssetClass + atAssetClass = AssetClass (authorityTokenSymbol, atTokenName) + + -- + + mockEffectInputDatum :: Datum + mockEffectInputDatum = unitDatum + mockEffectInput :: TxOut + mockEffectInput = + TxOut + { txOutAddress = mockEffectAddress + , txOutValue = gat -- Will be burnt + , txOutDatumHash = Just $ toDatumHash mockEffectInputDatum + } + + -- + + mockEffectOutputDatum :: Datum + mockEffectOutputDatum = mockEffectInputDatum + mockEffectOutput :: TxOut + mockEffectOutput = + mockEffectInput + { txOutValue = minAda + , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum + } + + -- + + governorInputDatum' :: GovernorDatum + governorInputDatum' = + GovernorDatum + { proposalThresholds = defaultProposalThresholds + , nextProposalId = ProposalId 5 + } + governorInputDatum :: Datum + governorInputDatum = Datum $ toBuiltinData governorInputDatum' + governorInput :: TxOut + governorInput = + TxOut + { txOutAddress = govValidatorAddress + , txOutValue = gst + , txOutDatumHash = Just $ toDatumHash governorInputDatum + } + + -- + + governorOutputDatum' :: GovernorDatum + governorOutputDatum' = governorInputDatum' + governorOutputDatum :: Datum + governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' + governorOutput :: TxOut + governorOutput = + governorInput + { txOutDatumHash = Just $ toDatumHash governorOutputDatum + , txOutValue = gst <> minAda + } + + -- + + ownInputRef :: TxOutRef + ownInputRef = TxOutRef "f867238a04597c99a0b9858746557d305025cca3b9f78ea14d5c88c4cfcf58ff" 1 + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo ownInputRef governorInput + , TxInInfo + (TxOutRef "ecff06d7cf99089294569cc8b92609e44927278f9901730715d14634fbc10089" 1) + mockEffectInput + ] + , txInfoOutputs = + [ governorOutput + , mockEffectOutput + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = burntGAT + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = + datumPair + <$> [ governorInputDatum + , governorOutputDatum + , mockEffectInputDatum + , mockEffectOutputDatum + ] + , txInfoId = "9a12a605086a9f866731869a42d0558036fc739c74fea3849aa41562c015aaf9" + } + , scriptContextPurpose = Spending ownInputRef + } diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index 9d88a7e..e778fca 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -60,8 +60,8 @@ proposalCreation = let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST effects = AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) ] proposalDatum :: Datum proposalDatum = @@ -155,8 +155,8 @@ cosignProposal newSigners = let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST effects = AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) ] proposalBefore :: ProposalDatum proposalBefore = @@ -193,7 +193,7 @@ cosignProposal newSigners = mconcat [ Value.singleton "" "" 10_000_000 , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - , Value.singleton stakeSymbol "" 1 + , Value.assetClassValue stakeAssetClass 1 ] , txOutDatumHash = Just (toDatumHash stakeDatum) } @@ -214,7 +214,7 @@ cosignProposal newSigners = mconcat [ Value.singleton "" "" 10_000_000 , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - , Value.singleton stakeSymbol "" 1 + , Value.assetClassValue stakeAssetClass 1 ] , txOutDatumHash = Just (toDatumHash stakeDatum) } diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index 9e109e2..c6f40a7 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -15,15 +15,20 @@ module Sample.Shared ( -- ** Stake stake, - stakeSymbol, + stakeAssetClass, stakeValidatorHash, stakeAddress, + stakeSymbol, -- ** Governor governor, govPolicy, govValidator, govSymbol, + govAssetClass, + govValidatorAddress, + govValidatorHash, + gstUTXORef, -- ** Proposal defaultProposalThresholds, @@ -32,6 +37,10 @@ module Sample.Shared ( proposalValidatorHash, proposalValidatorAddress, + -- ** Authority + authorityToken, + authorityTokenSymbol, + -- ** Treasury treasuryOut, gatTn, @@ -41,22 +50,31 @@ module Sample.Shared ( wrongEffHash, ) where +import Agora.AuthorityToken import Agora.Effect.NoOp (noOpValidator) import Agora.Governor ( Governor (Governor), + ) +import Agora.Governor.Scripts ( + authorityTokenFromGovernor, + authorityTokenSymbolFromGovernor, governorPolicy, + governorSTAssetClassFromGovernor, governorValidator, + governorValidatorHash, + proposalFromGovernor, + proposalSTSymbolFromGovernor, + proposalValidatorHashFromGovernor, + stakeFromGovernor, + stakeSTAssetClassFromGovernor, + stakeSTSymbolFromGovernor, + stakeValidatorHashFromGovernor, ) import Agora.Proposal ( Proposal (..), ProposalThresholds (..), ) -import Agora.Proposal.Scripts ( - proposalPolicy, - proposalValidator, - ) import Agora.Stake (Stake (..)) -import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Agora.Treasury (treasuryValidator) import Agora.Utils (validatorHashToTokenName) import Plutarch.Api.V1 ( @@ -73,38 +91,46 @@ import Plutus.V1.Ledger.Api ( CurrencySymbol, MintingPolicy (..), PubKeyHash, + TxOutRef (TxOutRef), + Value, ) import Plutus.V1.Ledger.Contexts ( TxOut (..), ) import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..)) -import Plutus.V1.Ledger.Value (TokenName, Value) +import Plutus.V1.Ledger.Value (AssetClass, TokenName) import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- stake :: Stake -stake = - Stake - { gtClassRef = - Tagged $ - Value.assetClass - "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" - "LQ" - , proposalSTClass = Value.assetClass proposalPolicySymbol "" - } +stake = stakeFromGovernor governor stakeSymbol :: CurrencySymbol -stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef +stakeSymbol = stakeSTSymbolFromGovernor governor + +stakeAssetClass :: AssetClass +stakeAssetClass = stakeSTAssetClassFromGovernor governor stakeValidatorHash :: ValidatorHash -stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake) +stakeValidatorHash = stakeValidatorHashFromGovernor governor stakeAddress :: Address stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing +gstUTXORef :: TxOutRef +gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0 + governor :: Governor -governor = Governor +governor = Governor oref gt mc + where + oref = gstUTXORef + gt = + Tagged $ + Value.assetClass + "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" + "LQ" + mc = 6 govPolicy :: MintingPolicy govPolicy = mkMintingPolicy (governorPolicy governor) @@ -115,16 +141,20 @@ govValidator = mkValidator (governorValidator governor) govSymbol :: CurrencySymbol govSymbol = mintingPolicySymbol govPolicy +govAssetClass :: AssetClass +govAssetClass = governorSTAssetClassFromGovernor governor + +govValidatorHash :: ValidatorHash +govValidatorHash = governorValidatorHash governor + +govValidatorAddress :: Address +govValidatorAddress = scriptHashAddress govValidatorHash + proposal :: Proposal -proposal = - Proposal - { governorSTAssetClass = Value.assetClass govSymbol "" - , stakeSTAssetClass = Value.assetClass stakeSymbol "" - , maximumCosigners = 6 - } +proposal = proposalFromGovernor governor proposalPolicySymbol :: CurrencySymbol -proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) +proposalPolicySymbol = proposalSTSymbolFromGovernor governor -- | A sample 'PubKeyHash'. signer :: PubKeyHash @@ -135,7 +165,7 @@ signer2 :: PubKeyHash signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192" proposalValidatorHash :: ValidatorHash -proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal) +proposalValidatorHash = proposalValidatorHashFromGovernor governor proposalValidatorAddress :: Address proposalValidatorAddress = scriptHashAddress proposalValidatorHash @@ -148,6 +178,12 @@ defaultProposalThresholds = , startVoting = Tagged 10 } +authorityToken :: AuthorityToken +authorityToken = authorityTokenFromGovernor governor + +authorityTokenSymbol :: CurrencySymbol +authorityTokenSymbol = authorityTokenSymbolFromGovernor governor + ------------------------------------------------------------------ treasuryOut :: TxOut diff --git a/agora-sample/Sample/Stake.hs b/agora-sample/Sample/Stake.hs index 7c6ed2e..723af00 100644 --- a/agora-sample/Sample/Stake.hs +++ b/agora-sample/Sample/Stake.hs @@ -7,6 +7,7 @@ This module tests primarily the happy path for Stake creation -} module Sample.Stake ( stake, + stakeAssetClass, stakeSymbol, validatorHashTN, signer, @@ -60,7 +61,7 @@ validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValid -- | This script context should be a valid transaction. stakeCreation :: ScriptContext stakeCreation = - let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST + let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST datum :: Datum datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer []) in ScriptContext @@ -120,7 +121,7 @@ data DepositWithdrawExample = DepositWithdrawExample -- | Create a ScriptContext that deposits or withdraws, given the config for it. stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw config = - let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST + let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST stakeBefore :: StakeDatum stakeBefore = StakeDatum config.startAmount signer [] diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 62d2ca3..d2c90f7 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup) import Spec.AuthorityToken qualified as AuthorityToken import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal +import Spec.Governor qualified as Governor import Spec.Model.MultiSig qualified as MultiSig import Spec.Proposal qualified as Proposal import Spec.Stake qualified as Stake @@ -42,7 +43,10 @@ main = "AuthorityToken tests" AuthorityToken.tests , testGroup - "Utility functions tests" + "Governor tests" + Governor.tests + , testGroup + "Utility tests" Utils.tests , testGroup "Multisig tests" diff --git a/agora-test/Spec/Governor.hs b/agora-test/Spec/Governor.hs new file mode 100644 index 0000000..89c43f8 --- /dev/null +++ b/agora-test/Spec/Governor.hs @@ -0,0 +1,57 @@ +{- | +Module : Spec.Governor +Maintainer : connor@mlabs.city +Description: Tests for Agora governor. + +Thie module exports `tests`, a list of `TestTree`s, which ensure +that Agora's governor component workds as intended. + +Tests should pass when the validator or policy is given one of the +valid script contexts, which are defined in 'Agora.Sample.Governor'. + +TODO: Add negative test cases, see [#76](https://github.com/Liqwid-Labs/agora/issues/76). +-} +module Spec.Governor (tests) where + +import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..)) +import Agora.Governor.Scripts (governorPolicy, governorValidator) +import Agora.Proposal (ProposalId (..)) +import Sample.Governor (createProposal, mintGATs, mintGST, mutateState) +import Sample.Shared qualified as Shared +import Test.Tasty (TestTree, testGroup) +import Test.Util (policySucceedsWith, validatorSucceedsWith) + +-------------------------------------------------------------------------------- + +tests :: [TestTree] +tests = + [ testGroup + "policy" + [ policySucceedsWith + "GST minting" + (governorPolicy Shared.governor) + () + mintGST + ] + , testGroup + "validator" + [ validatorSucceedsWith + "proposal creation" + (governorValidator Shared.governor) + (GovernorDatum Shared.defaultProposalThresholds (ProposalId 0)) + CreateProposal + createProposal + , validatorSucceedsWith + "GATs minting" + (governorValidator Shared.governor) + (GovernorDatum Shared.defaultProposalThresholds (ProposalId 5)) + MintGATs + mintGATs + , validatorSucceedsWith + "mutate governor state" + (governorValidator Shared.governor) + (GovernorDatum Shared.defaultProposalThresholds (ProposalId 5)) + MutateGovernor + mutateState + ] + ] diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index 310e562..cb049ed 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -12,6 +12,7 @@ module Spec.Proposal (tests) where -------------------------------------------------------------------------------- import Agora.Proposal ( + Proposal (..), ProposalDatum (ProposalDatum), ProposalId (ProposalId), ProposalRedeemer (Cosign), @@ -49,7 +50,7 @@ tests = "policy" [ policySucceedsWith "proposalCreation" - (proposalPolicy Shared.proposal) + (proposalPolicy Shared.proposal.governorSTAssetClass) () Proposal.proposalCreation ] @@ -64,8 +65,8 @@ tests = { proposalId = ProposalId 0 , effects = AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) ] , status = Draft , cosigners = [signer] @@ -73,8 +74,8 @@ tests = , votes = emptyVotesFor $ AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) ] } ) diff --git a/agora-test/Spec/Utils.hs b/agora-test/Spec/Utils.hs index 16e62d9..e255cf2 100644 --- a/agora-test/Spec/Utils.hs +++ b/agora-test/Spec/Utils.hs @@ -7,7 +7,138 @@ Tests for utility functions in 'Agora.Utils'. -} module Spec.Utils (tests) where +-------------------------------------------------------------------------------- + +import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort) + +-------------------------------------------------------------------------------- + +import Data.List (nub, sort) +import Data.Set as S + +-------------------------------------------------------------------------------- + import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) + +-------------------------------------------------------------------------------- tests :: [TestTree] -tests = [] +tests = + [ testProperty "'pmsort' sorts a list properly" prop_msortCorrect + , testProperty "'pmerge' merges two sorted lists into one sorted list" prop_mergeCorrect + , testProperty "'phalve' splits a list in half as expected" prop_halveCorrect + , testProperty "'pnubSort' sorts a list and remove duplicate elements" prop_nubSortProperly + , testProperty "'pisUniq' can tell whether all elements in a list are unique" prop_uniqueList + ] + +-------------------------------------------------------------------------------- + +-- | Yield true if 'Agora.Utils.pmsort' sorts a given list correctly. +prop_msortCorrect :: [Integer] -> Bool +prop_msortCorrect l = sorted == expected + where + -- Expected sorted list, using 'Data.List.sort'. + expected :: [Integer] + expected = sort l + + -- + + psorted :: Term _ (PBuiltinList PInteger) + psorted = pmsort # pconstant l + + sorted :: [Integer] + sorted = plift psorted + +-- | Yield true if 'Agora.Utils.pmerge' merges two list into a ordered list correctly. +prop_mergeCorrect :: [Integer] -> [Integer] -> Bool +prop_mergeCorrect a b = merged == expected + where + -- Sorted list a and b + sa = sort a + sb = sort b + + -- Merge two lists which are assumed to be ordered. + merge :: [Integer] -> [Integer] -> [Integer] + merge xs [] = xs + merge [] ys = ys + merge sx@(x : xs) sy@(y : ys) + | x <= y = x : merge xs sy + | otherwise = y : merge sx ys + + expected :: [Integer] + expected = merge sa sb + + -- + + pmerged :: Term _ (PBuiltinList PInteger) + pmerged = pmergeBy # plam (#<) # pconstant sa # pconstant sb + + merged :: [Integer] + merged = plift pmerged + +{- | Yield true if Plutarch level 'Agora.Utils.phalve' splits a given list + as its Haskell level counterpart does. +-} +prop_halveCorrect :: [Integer] -> Bool +prop_halveCorrect l = halved == expected + where + -- Halve a list. + halve :: [Integer] -> ([Integer], [Integer]) + halve xs = go xs xs + where + go xs [] = ([], xs) + go (x : xs) [_] = ([x], xs) + go (x : xs) (_ : _ : ys) = + let (first, last) = + go xs ys + in (x : first, last) + go [] _ = ([], []) + + expected :: ([Integer], [Integer]) + expected = halve l + + -- + + phalved :: Term _ (PPair (PBuiltinList PInteger) (PBuiltinList PInteger)) + phalved = phalve # pconstant l + + halved :: ([Integer], [Integer]) + halved = + let f = plift $ pmatch phalved $ \(PPair x _) -> x + s = plift $ pmatch phalved $ \(PPair _ x) -> x + in (f, s) + +{- | Yield true if 'Agora.Utils.pnubSort' sorts and removes + duplicate elements from a given list. +-} +prop_nubSortProperly :: [Integer] -> Bool +prop_nubSortProperly l = nubbed == expected + where + -- Sort and list and then nub it. + expected :: [Integer] + expected = nub $ sort l + + -- + + pnubbed :: Term _ (PBuiltinList PInteger) + pnubbed = pnubSort # pconstant l + + nubbed :: [Integer] + nubbed = plift pnubbed + +{- | Yield true if 'Agora.Utils.isUnique' can correctly determine + whether a given list only contains unique elements or not. +-} +prop_uniqueList :: [Integer] -> Bool +prop_uniqueList l = isUnique == expected + where + -- Convert input list to a set. + -- If the set's size equals to list's size, + -- the list only contains unique elements. + expected :: Bool + expected = S.size (S.fromList l) == length l + + -- + + isUnique = plift $ pisUniq # pconstant l diff --git a/agora.cabal b/agora.cabal index e5fd3b6..c8ce871 100644 --- a/agora.cabal +++ b/agora.cabal @@ -119,6 +119,7 @@ common test-deps , tasty , tasty-hedgehog , tasty-hunit + , tasty-quickcheck common exe-opts ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0 @@ -131,6 +132,7 @@ library Agora.Effect.NoOp Agora.Effect.TreasuryWithdrawal Agora.Governor + Agora.Governor.Scripts Agora.MultiSig Agora.Proposal Agora.Proposal.Scripts @@ -162,12 +164,10 @@ library agora-testlib library agora-sample import: lang, deps, test-deps - build-depends: - , agora - , agora-testlib - + build-depends: agora-testlib exposed-modules: Sample.Effect.TreasuryWithdrawal + Sample.Governor Sample.Proposal Sample.Shared Sample.Stake @@ -183,6 +183,7 @@ test-suite agora-test other-modules: Spec.AuthorityToken Spec.Effect.TreasuryWithdrawal + Spec.Governor Spec.Model.MultiSig Spec.Proposal Spec.Stake @@ -190,7 +191,6 @@ test-suite agora-test Spec.Utils build-depends: - , agora , agora-sample , agora-testlib diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index ae6a7ce..9692ed3 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -17,6 +17,7 @@ import Plutarch.Api.V1 ( PAddress (..), PCredential (..), PCurrencySymbol (..), + PMintingPolicy, PScriptContext (..), PScriptPurpose (..), PTxInInfo (PTxInInfo), @@ -127,9 +128,7 @@ singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do ] -- | Policy given 'AuthorityToken' params. -authorityTokenPolicy :: - AuthorityToken -> - Term s (PData :--> PScriptContext :--> PUnit) +authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy authorityTokenPolicy params = plam $ \_redeemer ctx' -> pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do @@ -156,7 +155,6 @@ authorityTokenPolicy params = authorityTokensValidIn # ownSymbol # txOut - - pure $ pconstant () + pure $ popaque $ pconstant () ) - (pconstant ()) + (popaque $ pconstant ()) diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index bf35726..4f64a76 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -2,7 +2,7 @@ {- | Module : Agora.Governor -Maintainer : emi@haskell.fyi +Maintainer : connor@mlabs.city Description: Governor entity scripts acting as authority of entire system. Governor entity scripts acting as authority of entire system. @@ -14,17 +14,52 @@ module Agora.Governor ( Governor (..), -- * Plutarch-land + PGovernorDatum (..), + PGovernorRedeemer (..), - -- * Scripts - governorPolicy, - governorValidator, + -- * Utilities + pgetNextProposalId, + getNextProposalId, + governorDatumValid, ) where -import Agora.Proposal (ProposalId, ProposalThresholds) +-------------------------------------------------------------------------------- + +import Control.Applicative (Const) import GHC.Generics qualified as GHC -import Plutarch.Api.V1 (PMintingPolicy, PValidator) +import Generics.SOP (Generic, I (I)) + +-------------------------------------------------------------------------------- + +import Agora.Proposal ( + PProposalId (..), + PProposalThresholds (..), + ProposalId (ProposalId), + ProposalThresholds, + ) +import Agora.SafeMoney (GTTag) +import Agora.Utils (tclet) + +-------------------------------------------------------------------------------- + +import Plutarch.DataRepr ( + DerivePConstantViaData (..), + PDataFields, + PIsDataReprInstances (PIsDataReprInstances), + ) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) +import Plutarch.SafeMoney (Tagged (..), puntag) +import Plutarch.TryFrom (PTryFrom (..)) +import Plutarch.Unsafe (punsafeCoerce) + +-------------------------------------------------------------------------------- + +import Plutus.V1.Ledger.Api (TxOutRef) +import Plutus.V1.Ledger.Value (AssetClass (..)) import PlutusTx qualified +-------------------------------------------------------------------------------- + -- | Datum for the Governor script. data GovernorDatum = GovernorDatum { proposalThresholds :: ProposalThresholds @@ -32,7 +67,7 @@ data GovernorDatum = GovernorDatum , nextProposalId :: ProposalId -- ^ What tag the next proposal will get upon creating. } - deriving stock (GHC.Generic) + deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)] @@ -41,6 +76,8 @@ PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)] 1. The gating of Proposal creation. 2. The gating of minting authority tokens. + + Parameters of the governor can also be mutated by an effect. -} data GovernorRedeemer = -- | Checks that a proposal was created lawfully, and allows it. @@ -48,23 +85,106 @@ data GovernorRedeemer | -- | Checks that a SINGLE proposal finished correctly, -- and allows minting GATs for each effect script. MintGATs - deriving stock (GHC.Generic) + | -- | Allows effects to mutate the parameters. + MutateGovernor + deriving stock (Show, GHC.Generic) -PlutusTx.makeIsDataIndexed ''GovernorRedeemer [('CreateProposal, 0), ('MintGATs, 1)] +PlutusTx.makeIsDataIndexed + ''GovernorRedeemer + [ ('CreateProposal, 0) + , ('MintGATs, 1) + , ('MutateGovernor, 2) + ] -- | Parameters for creating Governor scripts. -data Governor - = Governor +data Governor = Governor + { gstOutRef :: TxOutRef + -- ^ Referenced utxo will be spent to mint the GST. + , gtClassRef :: Tagged GTTag AssetClass + -- ^ Governance token of the system. + , maximumCosigners :: Integer + -- ^ Arbitrary limit for maximum amount of cosigners on a proposal. + -- See `Agora.Proposal.proposalDatumValid`. + } deriving stock (GHC.Generic) -------------------------------------------------------------------------------- --- | Policy for Governors. -governorPolicy :: Governor -> ClosedTerm PMintingPolicy -governorPolicy _ = - plam $ \_redeemer _ctx' -> popaque (pconstant ()) +-- | Plutarch-level datum for the Governor script. +newtype PGovernorDatum (s :: S) = PGovernorDatum + { getGovernorDatum :: + Term + s + ( PDataRecord + '[ "proposalThresholds" ':= PProposalThresholds + , "nextProposalId" ':= PProposalId + ] + ) + } + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields, PEq) + via PIsDataReprInstances PGovernorDatum --- | Validator for Governors. -governorValidator :: Governor -> ClosedTerm PValidator -governorValidator _ = - plam $ \_datum _redeemer _ctx' -> popaque (pconstant ()) +instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum +deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum) + +-- FIXME: derive this via 'PIsDataReprInstances' +-- Blocked by: PProposalThresholds +instance PTryFrom PData (PAsData PGovernorDatum) where + type PTryFromExcess PData (PAsData PGovernorDatum) = Const () + + ptryFrom' d k = k (punsafeCoerce d, ()) + +-- | Plutarch-level version of 'GovernorRedeemer'. +data PGovernorRedeemer (s :: S) + = PCreateProposal (Term s (PDataRecord '[])) + | PMintGATs (Term s (PDataRecord '[])) + | PMutateGovernor (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PGovernorRedeemer + +instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer +deriving via (DerivePConstantViaData GovernorRedeemer PGovernorRedeemer) instance (PConstantDecl GovernorRedeemer) + +deriving via PAsData (PIsDataReprInstances PGovernorRedeemer) instance PTryFrom PData (PAsData PGovernorRedeemer) + +-------------------------------------------------------------------------------- + +-- | Plutrach version of 'getNextProposalId'. +pgetNextProposalId :: Term s (PProposalId :--> PProposalId) +pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1 + +-- | Get next proposal id. +getNextProposalId :: ProposalId -> ProposalId +getNextProposalId (ProposalId pid) = ProposalId $ pid + 1 + +-------------------------------------------------------------------------------- + +governorDatumValid :: Term s (PGovernorDatum :--> PBool) +governorDatumValid = phoistAcyclic $ + plam $ \datum -> unTermCont $ do + thresholds <- + tcont $ + pletFields @'["execute", "draft", "vote"] $ + pfield @"proposalThresholds" # datum + + execute <- tclet $ puntag thresholds.execute + draft <- tclet $ puntag thresholds.draft + vote <- tclet $ puntag thresholds.vote + + pure $ + foldr1 + (#&&) + [ ptraceIfFalse "Execute threshold is less than or equal to" $ 0 #<= execute + , ptraceIfFalse "Draft threshold is less than or equal to " $ 0 #<= draft + , ptraceIfFalse "Vote threshold is less than or equal to " $ 0 #<= vote + , ptraceIfFalse "Draft threshold is less than vote threshold" $ draft #<= vote + , ptraceIfFalse "Execute threshold is less than vote threshold" $ vote #< execute + ] diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs new file mode 100644 index 0000000..8389f1d --- /dev/null +++ b/agora/Agora/Governor/Scripts.hs @@ -0,0 +1,822 @@ +{- | +Module : Agora.Governor.Scripts +Maintainer : connor@mlabs.city +Description: Plutus scripts for Governors. + +Plutus scripts for Governors. +-} +module Agora.Governor.Scripts ( + -- * GST + -- $gst + + -- * Scripts + governorPolicy, + governorValidator, + + -- * Bridges + governorSTSymbolFromGovernor, + governorSTAssetClassFromGovernor, + proposalSTAssetClassFromGovernor, + stakeSTSymbolFromGovernor, + stakeFromGovernor, + stakeValidatorHashFromGovernor, + proposalFromGovernor, + proposalValidatorHashFromGovernor, + proposalSTSymbolFromGovernor, + stakeSTAssetClassFromGovernor, + governorValidatorHash, + authorityTokenFromGovernor, + authorityTokenSymbolFromGovernor, +) where + +-------------------------------------------------------------------------------- + +import Agora.AuthorityToken ( + AuthorityToken (..), + authorityTokenPolicy, + authorityTokensValidIn, + singleAuthorityTokenBurned, + ) +import Agora.Governor ( + Governor (gstOutRef, gtClassRef, maximumCosigners), + PGovernorDatum (PGovernorDatum), + PGovernorRedeemer (PCreateProposal, PMintGATs, PMutateGovernor), + governorDatumValid, + pgetNextProposalId, + ) +import Agora.Proposal ( + PProposalDatum (..), + PProposalId (..), + PProposalStatus (PFinished), + PResultTag, + Proposal (..), + ProposalStatus (Draft, Locked), + proposalDatumValid, + ) +import Agora.Proposal.Scripts ( + proposalPolicy, + proposalValidator, + ) +import Agora.Record +import Agora.SafeMoney (GTTag) +import Agora.Stake ( + PProposalLock (..), + PStakeDatum (..), + Stake (..), + ) +import Agora.Stake.Scripts ( + stakePolicy, + stakeValidator, + ) +import Agora.Utils ( + findOutputsToAddress, + hasOnlyOneTokenOfCurrencySymbol, + mustBePDJust, + mustBePJust, + mustFindDatum', + pfindTxInByTxOutRef, + pisDJust, + pisJust, + pisUTXOSpent, + psymbolValueOf, + ptryFindDatum, + ptxSignedBy, + pvalueSpent, + scriptHashFromAddress, + tcassert, + tclet, + tcmatch, + validatorHashToAddress, + validatorHashToTokenName, + ) + +-------------------------------------------------------------------------------- + +import Plutarch.Api.V1 ( + PAddress, + PCurrencySymbol, + PDatumHash, + PMap, + PMintingPolicy, + PScriptPurpose (PMinting, PSpending), + PTxOut, + PValidator, + PValidatorHash, + PValue, + mintingPolicySymbol, + mkMintingPolicy, + mkValidator, + validatorHash, + ) +import Plutarch.Api.V1.Extra ( + passetClass, + passetClassValueOf, + ) +import Plutarch.Map.Extra ( + pkeys, + plookup, + plookup', + ) +import Plutarch.SafeMoney ( + PDiscrete, + puntag, + pvalueDiscrete', + ) +import Plutarch.TryFrom (ptryFrom) + +-------------------------------------------------------------------------------- + +import Plutus.V1.Ledger.Api ( + CurrencySymbol (..), + MintingPolicy, + ) +import Plutus.V1.Ledger.Scripts (ValidatorHash (..)) +import Plutus.V1.Ledger.Value ( + AssetClass (..), + ) + +-------------------------------------------------------------------------------- + +{- $gst + Governance state token, aka. GST, is an NFT that identifies a UTXO that + carries the state datum of the Governance script. + + This token is minted by a one-shot monetary policy 'governorPolicy', + meaning that the token has guaranteed uniqueness. + + The 'governorValidator' ensures that exactly one GST stays + at the address of itself forever. +-} + +-------------------------------------------------------------------------------- + +{- | Policy for minting GSTs. + + This policy perform the following checks: + + - The UTXO referenced in the parameter is spent in the transaction. + - Exactly one GST is minted. + - Ensure the token name is empty. + - Said UTXO should carry a valid 'Agora.Governor.GovernorDatum'. + + 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. +-} +governorPolicy :: Governor -> ClosedTerm PMintingPolicy +governorPolicy gov = + plam $ \_ ctx' -> unTermCont $ do + let oref = pconstant gov.gstOutRef + + PMinting ((pfield @"_0" #) -> ownSymbol) <- tcmatch (pfromData $ pfield @"purpose" # ctx') + let ownAssetClass = passetClass # ownSymbol # pconstant "" + txInfo = pfromData $ pfield @"txInfo" # ctx' + + txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums"] txInfo + + tcassert "Referenced utxo should be spent" $ + pisUTXOSpent # oref # txInfoF.inputs + + tcassert "Exactly one token should be minted" $ + psymbolValueOf # ownSymbol # txInfoF.mint #== 1 + #&& passetClassValueOf # txInfoF.mint # ownAssetClass #== 1 + + govOutput <- + tclet $ + mustBePJust + # "Governor output not found" + #$ pfind + # plam + ( \((pfield @"value" #) . pfromData -> value) -> + psymbolValueOf # ownSymbol # value #== 1 + ) + # pfromData txInfoF.outputs + + let datumHash = pfield @"datumHash" # pfromData govOutput + datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums + + pure $ popaque $ governorDatumValid # datum + +{- | Validator for Governors. + + == Common checks + + The validator always ensures: + + - The UTXO which holds the GST must be spent. + - The GST always stays at the validator's address. + - The new state UTXO has a valid datum of type 'GovernorDatum'. + + == Creating a Proposal + + When the redeemer is 'CreateProposal', the script will check: + + - For governor's state datum: + + * 'nextProposalId' is advanced. + * Nothing is changed other that that. + + - Exactly one stake (the "input stake") must be provided in the input: + * At least 'Agora.Stake.stackedAmount' of GT must be spent in the transaction. + * The transaction must be signed by the stake owner. + + - Exactly one new proposal state token is minted. + - An UTXO which holds the newly minted proposal state token is sent to the proposal validator. + This UTXO must have a valid datum of type 'Agora.Proposal.ProposalDatum', the datum must: + + * Copy its id and thresholds from the governor's state. + * Have status set to 'Proposal.Draft'. + * Have zero votes. + * Have exactly one cosigner - the stake owner + + - An UTXO which holds the stake state token is sent back to the stake validator. + This UTXO must have a valid datum of type 'Agora.Stake.StakeDatum': + + * The 'Agora.Stake.stakedAmount' and 'Agora.Stake.owner' should not be changed, + comparing to the input stake. + * The new proposal locks must be appended to the 'Agora.Stake.lockedBy'. + + == Minting GATs + + When the redeemer is 'MintGATs', the script will check: + + - Governor's state is not changed. + - Exactly only one proposal is in the inputs. Let's call this the /input proposal/. + - The proposal is in the 'Proposal.Executable' state. + + NOTE: The input proposal is found by looking for the UTXO with a proposal state token in the inputs. + + === Effect Group Selection + + Currently a proposal can have two or more than two options to vote on, + meaning that it can contains two or more effect groups, + according to [#39](https://github.com/Liqwid-Labs/agora/issues/39). + + Either way, the shapes of 'Proposal.votes' and 'Proposal.effects' should be the same. + This is checked by 'Proposal.proposalDatumValid'. + + The script will look at the the 'Proposal.votes' to determine which group has the highest votes, + said group shoud be executed. + + During the process, minimum votes requirement will also be enforced. + + Next, the script will: + + - Ensure that for every effect in the said effect group, + exactly one valid GAT is minted and sent to the effect. + - The amount of GAT minted in the transaction should be equal to the number of effects. + - A new UTXO is sent to the proposal validator, this UTXO should: + + * Include the one proposal state token. + * Have a valid datum of type 'Proposal.ProposalDatum'. + This datum should be as same as the one of the input proposal, + except its status should be 'Proposal.Finished'. + + == Changing the State + + Redeemer 'MutateGovernor' allows the state datum to be changed by an external effect. + + In this case, the script will check + + - Exactly one GAT is burnt in the transaction. + - Said GAT is tagged by the effect. +-} +governorValidator :: Governor -> ClosedTerm PValidator +governorValidator gov = + plam $ \datum' redeemer' ctx' -> unTermCont $ do + (pfromData -> redeemer, _) <- tcont $ ptryFrom redeemer' + ctxF <- tcont $ pletFields @'["txInfo", "purpose"] ctx' + + txInfo' <- tclet $ pfromData $ ctxF.txInfo + txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums", "signatories"] txInfo' + + PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- tcmatch $ pfromData ctxF.purpose + + ((pfield @"resolved" #) -> ownInput) <- + tclet $ + mustBePJust # "Own input not found" + #$ pfindTxInByTxOutRef # ownInputRef # txInfoF.inputs + ownInputF <- tcont $ pletFields @'["address", "value"] ownInput + let ownAddress = pfromData $ ownInputF.address + + (pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- tcont $ ptryFrom datum' + oldGovernorDatumF <- tcont $ pletFields @'["proposalThresholds", "nextProposalId"] oldGovernorDatum + + -- Check that GST will be returned to the governor. + let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value + tcassert "Own input should have exactly one state token" $ + ownInputGSTAmount #== 1 + + ownOutputs <- tclet $ findOutputsToAddress # txInfoF.outputs # ownAddress + tcassert "Exactly one utxo should be sent to the governor" $ + plength # ownOutputs #== 1 + + ownOutput <- tcont $ pletFields @'["value", "datumHash"] $ phead # ownOutputs + let ownOuputGSTAmount = psymbolValueOf # pgstSymbol # ownOutput.value + tcassert "State token should stay at governor's address" $ + ownOuputGSTAmount #== 1 + + -- Check that own output have datum of type 'GovernorDatum'. + let outputGovernorStateDatumHash = + mustBePDJust # "Governor output doesn't have datum" # ownOutput.datumHash + newGovernorDatum <- + tclet $ + pfromData $ + mustBePJust # "Ouput governor state datum not found" + #$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums + tcassert "New datum is not valid" $ governorDatumValid # newGovernorDatum + + pure $ + pmatch redeemer $ \case + PCreateProposal _ -> unTermCont $ do + -- Check that the transaction advances proposal id. + + let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId + expectedNewDatum = + mkRecordConstr + PGovernorDatum + ( #proposalThresholds .= oldGovernorDatumF.proposalThresholds + .& #nextProposalId .= pdata expectedNextProposalId + ) + tcassert "Unexpected governor state datum" $ + newGovernorDatum #== expectedNewDatum + + -- Check that exactly one proposal token is being minted. + + tcassert "Exactly one proposal token must be minted" $ + hasOnlyOneTokenOfCurrencySymbol # ppstSymbol # txInfoF.mint + + -- Check that a stake is spent to create the propsal, + -- and the value it contains meets the requirement. + + stakeInput <- + tclet $ + mustBePJust # "Stake input not found" #$ pfind + # phoistAcyclic + ( plam $ + \((pfield @"resolved" #) -> txOut') -> unTermCont $ do + txOut <- tcont $ pletFields @'["address", "value"] txOut' + + pure $ + txOut.address #== pdata pstakeValidatorAddress + #&& psymbolValueOf # psstSymbol # txOut.value #== 1 + ) + # pfromData txInfoF.inputs + + stakeInputF <- tcont $ pletFields @'["datumHash", "value"] $ pfield @"resolved" # stakeInput + + tcassert "Stake input doesn't have datum" $ + pisDJust # stakeInputF.datumHash + + let stakeInputDatum = mustFindDatum' @PStakeDatum # stakeInputF.datumHash # txInfoF.datums + + stakeInputDatumF <- + tcont $ pletFields @["stakedAmount", "owner", "lockedBy"] stakeInputDatum + + tcassert "Required amount of stake GTs should be presented" $ + stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeInputF.value) + + -- TODO: Is this required? + tcassert "Tx should be signed by the stake owner" $ + ptxSignedBy # txInfoF.signatories # stakeInputDatumF.owner + + -- Check that the newly minted PST is sent to the proposal validator, + -- and the datum it carries is legal. + + outputsToProposalValidatorWithStateToken <- + tclet $ + pfilter + # phoistAcyclic + ( plam $ + \txOut' -> unTermCont $ do + txOut <- tcont $ pletFields @'["address", "value"] txOut' + + pure $ + txOut.address #== pdata pproposalValidatorAddress + #&& psymbolValueOf # ppstSymbol # txOut.value #== 1 + ) + # pfromData txInfoF.outputs + + tcassert "Exactly one UTXO with proposal state token should be sent to the proposal validator" $ + plength # outputsToProposalValidatorWithStateToken #== 1 + + outputDatumHash <- tclet $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken + + tcassert "The utxo paid to the proposal validator must have datum" $ + pisDJust # outputDatumHash + + proposalOutputDatum' <- + tclet $ + mustFindDatum' @PProposalDatum + # outputDatumHash + # txInfoF.datums + + tcassert "Proposal datum must be valid" $ + proposalDatumValid' # proposalOutputDatum' + + proposalOutputDatum <- + tcont $ + pletFields + @'["proposalId", "status", "cosigners", "thresholds", "votes"] + proposalOutputDatum' + + -- Id and thresholds should be copied from the old governor state datum. + tcassert "Invalid proposal id in proposal datum" $ + proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId + + tcassert "Invalid thresholds in proposal datum" $ + proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds + + -- The proposal at this point should be in draft state. + tcassert "Proposal state should be draft" $ + proposalOutputDatum.status #== pconstantData Draft + + tcassert "Proposal should have only one cosigner" $ + plength # pfromData proposalOutputDatum.cosigners #== 1 + + let cosigner = phead # pfromData proposalOutputDatum.cosigners + + tcassert "Cosigner should be the stake owner" $ + pdata stakeInputDatumF.owner #== cosigner + + -- Check the output stake has been proposly updated. + + stakeOutput <- + tclet $ + mustBePJust + # "Stake output not found" + #$ pfind + # phoistAcyclic + ( plam $ + \txOut' -> unTermCont $ do + txOut <- tcont $ pletFields @'["address", "value"] txOut' + + pure $ + txOut.address #== pdata pstakeValidatorAddress + #&& psymbolValueOf # psstSymbol # txOut.value #== 1 + ) + # pfromData txInfoF.outputs + + stakeOutputF <- tcont $ pletFields @'["datumHash", "value"] $ stakeOutput + + tcassert "Staked GTs should be sent back to stake validator" $ + stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeOutputF.value) + + let stakeOutputDatumHash = mustBePDJust # "Stake output should have datum" # stakeOutputF.datumHash + + stakeOutputDatum = + mustBePJust # "Stake output not found" #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums + + -- The stake should be locked by the newly created proposal. + + let possibleVoteResults = pkeys #$ pto $ pfromData proposalOutputDatum.votes + + mkProposalLock :: Term _ (PProposalId :--> PAsData PResultTag :--> PAsData PProposalLock) + mkProposalLock = + phoistAcyclic $ + plam + ( \pid rt' -> + pdata $ + mkRecordConstr + PProposalLock + ( #vote .= rt' .& #proposalTag .= pdata pid + ) + ) + + -- Append new locks to existing locks + expectedProposalLocks = + pconcat # stakeInputDatumF.lockedBy + #$ pmap # (mkProposalLock # proposalOutputDatum.proposalId) # possibleVoteResults + + expectedStakeOutputDatum = + pdata $ + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInputDatumF.stakedAmount + .& #owner .= stakeInputDatumF.owner + .& #lockedBy .= pdata expectedProposalLocks + ) + + tcassert "Unexpected stake output datum" $ expectedStakeOutputDatum #== stakeOutputDatum + + pure $ popaque $ pconstant () + + -------------------------------------------------------------------------- + + PMintGATs _ -> unTermCont $ do + tcassert "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum + + -- Filter out proposal inputs and ouputs using PST and the address of proposal validator. + + tcassert "The governor can only process one proposal at a time" $ + (psymbolValueOf # ppstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1 + + proposalInputF <- + tcont $ + pletFields @'["datumHash"] $ + pfield @"resolved" + #$ pfromData + $ mustBePJust + # "Proposal input not found" + #$ pfind + # plam + ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do + txOutF <- tcont $ pletFields @'["address", "value"] txOut + + pure $ + psymbolValueOf # ppstSymbol # txOutF.value #== 1 + #&& txOutF.address #== pdata pproposalValidatorAddress + ) + # pfromData txInfoF.inputs + + proposalOutputF <- + tcont $ + pletFields @'["datumHash"] $ + mustBePJust # "Proposal output not found" + #$ pfind + # plam + ( \txOut -> unTermCont $ do + txOutF <- tcont $ pletFields @'["address", "value"] txOut + pure $ + psymbolValueOf # ppstSymbol # txOutF.value #== 1 + #&& txOutF.address #== pdata pproposalValidatorAddress + ) + # pfromData txInfoF.outputs + + proposalInputDatum <- + tclet $ + mustFindDatum' @PProposalDatum + # proposalInputF.datumHash + # txInfoF.datums + proposalOutputDatum <- + tclet $ + mustFindDatum' @PProposalDatum + # proposalOutputF.datumHash + # txInfoF.datums + + tcassert "Proposal datum must be valid" $ + proposalDatumValid' # proposalInputDatum + #&& proposalDatumValid' # proposalOutputDatum + + proposalInputDatumF <- + tcont $ + pletFields @'["proposalId", "effects", "status", "cosigners", "thresholds", "votes"] + proposalInputDatum + + -- Check that the proposal state is advanced so that a proposal cannot be executed twice. + + tcassert "Proposal must be in locked(executable) state in order to execute effects" $ + proposalInputDatumF.status #== pconstantData Locked + + let expectedOutputProposalDatum = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalInputDatumF.proposalId + .& #effects .= proposalInputDatumF.effects + .& #status .= pdata (pcon $ PFinished pdnil) + .& #cosigners .= proposalInputDatumF.cosigners + .& #thresholds .= proposalInputDatumF.thresholds + .& #votes .= proposalInputDatumF.votes + ) + + tcassert "Unexpected output proposal datum" $ + pdata proposalOutputDatum #== pdata expectedOutputProposalDatum + + -- TODO: anything else to check here? + + -- Find the highest votes and the corresponding tag. + let highestVoteFolder = + phoistAcyclic $ + plam + ( \pair last' -> + pif + (pisJust # last') + ( unTermCont $ do + PJust last <- tcmatch last' + let lastHighestVote = pfromData $ psndBuiltin # last + thisVote = pfromData $ psndBuiltin # pair + pure $ pif (lastHighestVote #< thisVote) (pcon $ PJust pair) last' + ) + (pcon $ PJust pair) + ) + + votesList = pto $ pto $ pfromData proposalInputDatumF.votes + + maybeWinner = + pfoldr # highestVoteFolder # pcon PNothing # votesList + + winner <- tclet $ mustBePJust # "No winning outcome" # maybeWinner + + let highestVote = pfromData $ psndBuiltin # winner + minimumVotes = puntag $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds + + tcassert "Higgest vote doesn't meet the minimum requirement" $ minimumVotes #<= highestVote + + let finalResultTag = pfromData $ pfstBuiltin # winner + + -- The effects of the winner outcome. + effectGroup <- tclet $ plookup' # finalResultTag #$ proposalInputDatumF.effects + + gatCount <- tclet $ plength #$ pto $ pto effectGroup + + tcassert "Required amount of GATs should be minted" $ + psymbolValueOf # patSymbol # txInfoF.mint #== gatCount + + -- Ensure that every GAT goes to one of the effects in the winner effect group. + outputsWithGAT <- + tclet $ + pfilter + # phoistAcyclic + ( plam + ( \((pfield @"value" #) -> value) -> + 0 #< psymbolValueOf # patSymbol # value + ) + ) + # pfromData txInfoF.outputs + + tcassert "Output GATs is more than minted GATs" $ + plength # outputsWithGAT #== gatCount + + let gatOutputValidator' :: Term s (PMap PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool) + gatOutputValidator' = + phoistAcyclic $ + plam + ( \effects (pfromData -> output') -> unTermCont $ do + output <- tcont $ pletFields @'["address", "datumHash"] $ output' + + let scriptHash = + mustBePJust # "GAT receiver is not a script" + #$ scriptHashFromAddress # output.address + datumHash = + mustBePDJust # "Output to effect should have datum" + #$ output.datumHash + + expectedDatumHash = + mustBePJust # "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 + + pure $ + popaque $ + 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 + + -------------------------------------------------------------------------- + + PMutateGovernor _ -> unTermCont $ do + -- Check that a GAT is burnt. + pure $ popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint + where + -- Get th amount of governance tokens in a value. + pgtValueOf :: Term s (PValue :--> PDiscrete GTTag) + pgtValueOf = phoistAcyclic $ pvalueDiscrete' gov.gtClassRef + + -- The currency symbol of authority token. + patSymbol :: Term s PCurrencySymbol + patSymbol = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor gov + + -- The currency symbol of the proposal state token. + ppstSymbol :: Term s PCurrencySymbol + ppstSymbol = + let AssetClass (sym, _) = proposalSTAssetClassFromGovernor gov + in phoistAcyclic $ pconstant sym + + -- Is a proposal state datum valid? + proposalDatumValid' :: Term s (PProposalDatum :--> PBool) + proposalDatumValid' = + let params = proposalFromGovernor gov + in phoistAcyclic $ proposalDatumValid params + + -- The address of the proposal validator. + pproposalValidatorAddress :: Term s PAddress + pproposalValidatorAddress = + let vh = proposalValidatorHashFromGovernor gov + in phoistAcyclic $ pconstant $ validatorHashToAddress vh + + -- The address of the stake validator. + pstakeValidatorAddress :: Term s PAddress + pstakeValidatorAddress = + let vh = stakeValidatorHashFromGovernor gov + in phoistAcyclic $ pconstant $ validatorHashToAddress vh + + -- The currency symbol of the stake state token. + psstSymbol :: Term s PCurrencySymbol + psstSymbol = + let sym = stakeSTSymbolFromGovernor gov + in phoistAcyclic $ pconstant sym + + -- The currency symbol of the governor state token. + pgstSymbol :: Term s PCurrencySymbol + pgstSymbol = + let sym = governorSTSymbolFromGovernor gov + in phoistAcyclic $ pconstant sym + +-------------------------------------------------------------------------------- + +-- | Get the 'CurrencySymbol' of GST. +governorSTSymbolFromGovernor :: Governor -> CurrencySymbol +governorSTSymbolFromGovernor gov = mintingPolicySymbol policy + where + policy :: MintingPolicy + policy = mkMintingPolicy $ governorPolicy gov + +-- | Get the 'AssetClass' of GST. +governorSTAssetClassFromGovernor :: Governor -> AssetClass +governorSTAssetClassFromGovernor gov = AssetClass (symbol, "") + where + symbol :: CurrencySymbol + symbol = governorSTSymbolFromGovernor gov + +-- | Get the 'CurrencySymbol' of the proposal state token. +proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol +proposalSTSymbolFromGovernor gov = symbol + where + gstAC = governorSTAssetClassFromGovernor gov + policy = mkMintingPolicy $ proposalPolicy gstAC + symbol = mintingPolicySymbol policy + +-- | Get the 'AssetClass' of the proposal state token. +proposalSTAssetClassFromGovernor :: Governor -> AssetClass +proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "") + where + symbol = proposalSTSymbolFromGovernor gov + +-- | Get the 'CurrencySymbol' of the stake token/ +stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol +stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy + where + policy = mkMintingPolicy $ stakePolicy gov.gtClassRef + +{- | Get the 'AssetClass' of the stake token. + + Note that the token is tagged with the hash of the stake validator. + See 'Agora.Stake.Script.stakePolicy'. +-} +stakeSTAssetClassFromGovernor :: Governor -> AssetClass +stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName) + where + symbol = stakeSTSymbolFromGovernor gov + + -- Tag with the address where the token is being sent to. + tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov + +-- | Get the 'Stake' parameter, given the 'Governor' parameter. +stakeFromGovernor :: Governor -> Stake +stakeFromGovernor gov = + Stake gov.gtClassRef $ + proposalSTAssetClassFromGovernor gov + +-- | Get the hash of 'Agora.Stake.Script.stakePolicy'. +stakeValidatorHashFromGovernor :: Governor -> ValidatorHash +stakeValidatorHashFromGovernor gov = validatorHash validator + where + params = stakeFromGovernor gov + validator = mkValidator $ stakeValidator params + +-- | Get the 'Proposal' parameter, given the 'Governor' parameter. +proposalFromGovernor :: Governor -> Proposal +proposalFromGovernor gov = Proposal gstAC sstAC mc + where + gstAC = governorSTAssetClassFromGovernor gov + mc = gov.maximumCosigners + sstAC = stakeSTAssetClassFromGovernor gov + +-- | Get the hash of 'Agora.Proposal.proposalPolicy'. +proposalValidatorHashFromGovernor :: Governor -> ValidatorHash +proposalValidatorHashFromGovernor gov = validatorHash validator + where + params = proposalFromGovernor gov + validator = mkValidator $ proposalValidator params + +-- | Get the hash of 'Agora.Proposal.proposalValidator'. +governorValidatorHash :: Governor -> ValidatorHash +governorValidatorHash gov = validatorHash validator + where + validator = mkValidator $ governorValidator gov + +-- | Get the 'AuthorityToken' parameter given the 'Governor' parameter. +authorityTokenFromGovernor :: Governor -> AuthorityToken +authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov + +-- | Get the 'CurrencySymbol' of the authority token. +authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol +authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy + where + policy = mkMintingPolicy $ authorityTokenPolicy params + params = authorityTokenFromGovernor gov diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index b0f0bb0..794ea0a 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -48,7 +48,6 @@ import Agora.SafeMoney (GTTag) import Agora.Utils (pkeysEqual, pnotNull) import Control.Applicative (Const) import Control.Arrow (first) -import Plutarch.Builtin (PBuiltinMap) import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) import Plutarch.Lift ( DerivePConstantViaNewtype (..), @@ -174,10 +173,10 @@ emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0) data ProposalDatum = ProposalDatum { proposalId :: ProposalId -- ^ Identification of the proposal. - , -- TODO: could we encode this more efficiently? + -- 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 [(ValidatorHash, DatumHash)] + , effects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash) -- ^ Effect lookup table. First by result, then by effect hash. , status :: ProposalStatus -- ^ The status the proposal is in. @@ -414,17 +413,12 @@ proposalDatumValid proposal = plam $ \datum' -> unTermCont $ do datum <- tcont $ pletFields @'["effects", "cosigners", "votes"] $ datum' - let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)) - effects = - -- JUSTIFICATION: - -- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@ - -- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to - -- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@ - punsafeCoerce datum.effects - - atLeastOneNegativeResult :: Term _ PBool - atLeastOneNegativeResult = - pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects + let atLeastOneNegativeResult = + pany + # phoistAcyclic + (plam $ \m -> pnull #$ pto $ pfromData $ psndBuiltin # m) + #$ pto + $ pfromData datum.effects pure $ foldr1 diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 6968de8..ce2dcbe 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -21,7 +21,7 @@ import Agora.Utils ( anyOutput, findTxOutByTxOutRef, getMintingPolicySymbol, - pisUniq, + pisUniqBy, psymbolValueOf, ptokenSpent, ptxSignedBy, @@ -59,8 +59,11 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) - This policy cannot be burned. -} -proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy -proposalPolicy proposal = +proposalPolicy :: + -- | The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'. + AssetClass -> + ClosedTerm PMintingPolicy +proposalPolicy (AssetClass (govCs, govTn)) = plam $ \_redeemer ctx' -> unTermCont $ do PScriptContext ctx' <- tcmatch ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx' @@ -70,7 +73,6 @@ proposalPolicy proposal = let inputs = txInfo.inputs mintedValue = pfromData txInfo.mint - AssetClass (govCs, govTn) = proposal.governorSTAssetClass PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose let mintedProposalST = @@ -147,9 +149,10 @@ proposalValidator proposal = ownAddress <- tclet $ txOutF.address let stCurrencySymbol = - pconstant $ getMintingPolicySymbol (proposalPolicy proposal) + pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass) valueSpent <- tclet $ pvalueSpent # txInfoF.inputs spentST <- tclet $ psymbolValueOf # stCurrencySymbol #$ valueSpent + let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass stakeSTAssetClass <- tclet $ passetClass # pconstant stakeSym # pconstant stakeTn @@ -168,7 +171,10 @@ proposalValidator proposal = newSigs <- tclet $ pfield @"newCosigners" # r tcassert "Cosigners are unique" $ - pisUniq # newSigs + pisUniqBy + # phoistAcyclic (plam (#==)) + # phoistAcyclic (plam $ \(pfromData -> x) (pfromData -> y) -> x #< y) + # newSigs tcassert "Signed by all new cosigners" $ pall # signedBy # newSigs diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 3258f74..558bc13 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -32,8 +32,14 @@ module Agora.Utils ( pisJust, ptokenSpent, pkeysEqual, - pnub, + pnubSortBy, pisUniq, + pisUniqBy, + pisDJust, + pisUTXOSpent, + pmsortBy, + pmsort, + pnubSort, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -46,11 +52,20 @@ module Agora.Utils ( validatorHashToTokenName, pvalidatorHashToTokenName, getMintingPolicySymbol, + hasOnlyOneTokenOfCurrencySymbol, + mustFindDatum', + mustBePJust, + mustBePDJust, + validatorHashToAddress, + pmergeBy, + phalve, ) where -------------------------------------------------------------------------------- import Plutus.V1.Ledger.Api ( + Address (..), + Credential (..), CurrencySymbol, TokenName (..), ValidatorHash (..), @@ -83,7 +98,7 @@ import Plutarch.Api.V1 ( import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.Value (PValue (PValue)) -import Plutarch.Builtin (ppairDataBuiltin) +import Plutarch.Builtin (pforgetData, ppairDataBuiltin) import Plutarch.Map.Extra (pkeys) import Plutarch.Reducible (Reducible (Reduce)) import Plutarch.TryFrom (PTryFrom (PTryFromExcess), ptryFrom) @@ -346,38 +361,159 @@ ptokenSpent = {- | True if both maps have exactly the same keys. Using @'#=='@ is not sufficient, because keys returned are not ordered. -} -pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool) +pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) a b. Term s (PMap k a :--> PMap k b :--> PBool) pkeysEqual = phoistAcyclic $ plam $ \p q -> unTermCont $ do pks <- tclet $ pkeys # p qks <- tclet $ pkeys # q + pure $ - pall # plam (\pk -> pelem # pk # qks) # pks - #&& pall # plam (\qk -> pelem # qk # pks) # qks + pif + (plength # pks #== plength # qks) + ( unTermCont $ do + let comp = phoistAcyclic $ plam $ \(pfromData -> x) (pfromData -> y) -> x #< y + spks = pmsortBy # comp # pks + sqks = pmsortBy # comp # qks --- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved. -pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a) -pnub = - phoistAcyclic $ - precList - ( \self x xs -> - pif - (pnot #$ pelem # x # xs) - (pcons # x # (self # xs)) - (self # xs) - ) - (const pnil) + pure $ plistEquals # spks # sqks + ) + (pcon PFalse) --- | / O(n^2) /. Check if a list contains no duplicates. -pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> PBool) -pisUniq = - phoistAcyclic $ - precList - ( \self x xs -> - (pnot #$ pelem # x # xs) - #&& (self # xs) +-- | / O(nlogn) /. Sort and remove dupicate elements in a list. +pnubSortBy :: + forall list a (s :: S). + (PIsListLike list a) => + Term s ((a :--> a :--> PBool) :--> (a :--> a :--> PBool) :--> list a :--> list a) +pnubSortBy = phoistAcyclic $ + plam $ \eq comp l -> pif (pnull # l) l $ + unTermCont $ do + sl <- tclet $ pmsortBy # comp # l + + let x = phead # sl + xs = ptail # sl + + return $ pgo # eq # x # xs + where + pgo = phoistAcyclic pfix #$ plam pgo' + pgo' self eq seen l = + pif (pnull # l) (psingleton # seen) $ + unTermCont $ do + x <- tclet $ phead # l + xs <- tclet $ ptail # l + + return $ + pif + (eq # x # seen) + (self # eq # seen # xs) + (pcons # seen #$ self # eq # x # xs) + +-- | Special version of 'pnubSortBy', which requires elements have 'POrd'. +pnubSort :: + forall list a (s :: S). + (PIsListLike list a, POrd a) => + Term s (list a :--> list a) +pnubSort = phoistAcyclic $ pnubSortBy # eq # comp + where + eq = phoistAcyclic $ plam (#==) + comp = phoistAcyclic $ plam (#<) + +-- | / O(nlogn) /. Check if a list contains no duplicates. +pisUniqBy :: + forall list a (s :: S). + (PIsListLike list a) => + Term s ((a :--> a :--> PBool) :--> (a :--> a :--> PBool) :--> list a :--> PBool) +pisUniqBy = phoistAcyclic $ + plam $ \eq comp xs -> + let nubbed = pnubSortBy # eq # comp # xs + in plength # xs #== plength # nubbed + +-- | A special case of 'pisUniqBy' which requires elements have 'POrd' instance. +pisUniq :: forall list a (s :: S). (POrd a, PIsListLike list a) => Term s (list a :--> PBool) +pisUniq = phoistAcyclic $ pisUniqBy # eq # comp + where + eq = phoistAcyclic $ plam (#==) + comp = phoistAcyclic $ plam (#<) + +-- | Yield True if a given PMaybeData is of form @'PDJust' _@. +pisDJust :: Term s (PMaybeData a :--> PBool) +pisDJust = phoistAcyclic $ + plam $ \x -> + pmatch + x + ( \case + PDJust _ -> pconstant True + _ -> pconstant False ) - (const $ pcon PTrue) + +-- | Determines if a given UTXO is spent. +pisUTXOSpent :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) +pisUTXOSpent = phoistAcyclic $ + plam $ \oref inputs -> P.do + pisJust #$ pfindTxInByTxOutRef # oref # inputs + +-- | / O(n) /. Merge two lists which are assumed to be ordered, given a custom comparator. +pmergeBy :: (PIsListLike l a) => Term s ((a :--> a :--> PBool) :--> l a :--> l a :--> l a) +pmergeBy = phoistAcyclic $ pfix #$ plam pmergeBy' + where + pmergeBy' self comp a b = + pif (pnull # a) b $ + pif (pnull # b) a $ + unTermCont $ do + ah <- tclet $ phead # a + at <- tclet $ ptail # a + bh <- tclet $ phead # b + bt <- tclet $ ptail # b + + pure $ + pif + (comp # ah # bh) + (pcons # ah #$ self # comp # at # b) + (pcons # bh #$ self # comp # a # bt) + +{- | / O(nlogn) /. Merge sort, bottom-up version, given a custom comparator. + + Elements are arranged from lowest to highest, + keeping duplicates in the order they appeared in the input. +-} +pmsortBy :: (PIsListLike l a) => Term s ((a :--> a :--> PBool) :--> l a :--> l a) +pmsortBy = phoistAcyclic $ pfix #$ plam pmsortBy' + where + pmsortBy' self comp xs = pif (pnull # xs) pnil $ + pif (pnull #$ ptail # xs) xs $ + pmatch (phalve # xs) $ \(PPair fh sh) -> + let sfh = self # comp # fh + ssh = self # comp # sh + in pmergeBy # comp # sfh # ssh + +-- | A special case of 'pmsortBy' which requires elements have 'POrd' instance. +pmsort :: (POrd a, PIsListLike l a) => Term s (l a :--> l a) +pmsort = phoistAcyclic $ pmsortBy # comp + where + comp = phoistAcyclic $ plam (#<) + +-- | Split a list in half. +phalve :: (PIsListLike l a) => Term s (l a :--> PPair (l a) (l a)) +phalve = phoistAcyclic $ plam $ \l -> go # l # l + where + go = phoistAcyclic $ pfix #$ plam go' + go' self xs ys = + pif + (pnull # ys) + (pcon $ PPair pnil xs) + ( unTermCont $ do + yt <- tclet $ ptail # ys + + xh <- tclet $ phead # xs + xt <- tclet $ ptail # xs + + pure $ + pif (pnull # yt) (pcon $ PPair (psingleton # xh) xt) $ + unTermCont $ do + yt' <- tclet $ ptail # yt + pure $ + pmatch (self # xt # yt') $ \(PPair first last) -> + pcon $ PPair (pcons # xh # first) last + ) -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed @@ -514,3 +650,49 @@ pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh)) -- | Get the CurrencySymbol of a PMintingPolicy. getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v + +-- | The entire value only contains one token of the given currency symbol. +hasOnlyOneTokenOfCurrencySymbol :: Term s (PCurrencySymbol :--> PValue :--> PBool) +hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $ + plam $ \cs vs -> P.do + psymbolValueOf # cs # vs #== 1 + #&& (plength #$ pto $ pto $ pto vs) #== 1 + +-- | Find datum given a maybe datum hash +mustFindDatum' :: + forall (datum :: PType). + (PIsData datum, PTryFrom PData (PAsData datum)) => + forall s. + Term + s + ( PMaybeData PDatumHash + :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) + :--> datum + ) +mustFindDatum' = phoistAcyclic $ + plam $ \mdh datums -> unTermCont $ do + let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh + dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums + (d, _) <- tcont $ ptryFrom $ pforgetData $ pdata dt + pure $ pfromData d + +{- | Extract the value stored in a PMaybe container. + If there's no value, throw an error with the given message. +-} +mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a) +mustBePJust = phoistAcyclic $ + plam $ \emsg mv' -> pmatch mv' $ \case + PJust v -> v + _ -> ptraceError emsg + +{- | Extract the value stored in a PMaybeData container. + If there's no value, throw an error with the given message. +-} +mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a) +mustBePDJust = phoistAcyclic $ + plam $ \emsg mv' -> pmatch mv' $ \case + PDJust ((pfield @"_0" #) -> v) -> v + _ -> ptraceError emsg + +validatorHashToAddress :: ValidatorHash -> Address +validatorHashToAddress vh = Address (ScriptCredential vh) Nothing