Merge pull request #61 from Liqwid-Labs/connor/governor
Implementation of the governor components
This commit is contained in:
方泓睿
GitHub
commit
72d615bf0a
18 changed files with 2114 additions and 132 deletions
5
Makefile
5
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 <command> [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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
619
agora-sample/Sample/Governor.hs
Normal file
619
agora-sample/Sample/Governor.hs
Normal file
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 []
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
57
agora-test/Spec/Governor.hs
Normal file
57
agora-test/Spec/Governor.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
@ -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)
|
||||
]
|
||||
}
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
10
agora.cabal
10
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ())
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
|
|
|
|||
822
agora/Agora/Governor/Scripts.hs
Normal file
822
agora/Agora/Governor/Scripts.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue