Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

apply suggestions

Browse source
This commit is contained in:
Emily Martins 2022-04-28 16:18:07 +02:00
parent 5622a9d6db
commit 18622c76d2
8 changed files with 273 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

23
agora/Agora/Proposal.hs
View file

@ -17,6 +17,7 @@ module Agora.Proposal (
ProposalVotes (..),
ProposalId (..),
ResultTag (..),
emptyVotesFor,
-- * Plutarch-land
PProposalDatum (..),
@ -67,7 +68,8 @@ import Plutus.V1.Ledger.Value (AssetClass)
{- | Identifies a Proposal, issued upon creation of a proposal. In practice,
this number starts at zero, and increments by one for each proposal.
The 100th proposal will be @'ProposalId' 99@. This counter lives
in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
'Agora.Governor.pgetNextProposalId'.
-}
newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
@ -140,7 +142,7 @@ data ProposalThresholds = ProposalThresholds
--
-- It is recommended this be a high enough amount, in order to prevent DOS from bad
-- actors.
, vote :: Tagged GTTag Integer
, startVoting :: Tagged GTTag Integer
-- ^ How much GT required to allow voting to happen.
-- (i.e. to move into 'VotingReady')
}
@ -165,6 +167,10 @@ newtype ProposalVotes = ProposalVotes
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock (Eq, Show, GHC.Generic)
-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
-- | Haskell-level datum for Proposal scripts.
data ProposalDatum = ProposalDatum
{ proposalId :: ProposalId
@ -206,18 +212,19 @@ data ProposalRedeemer
--
-- === @'Draft' -> 'VotingReady'@:
--
-- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
-- 2. The proposal hasn't been alive for longer than the review time.
-- 1. The sum of all of the cosigner's GT is larger than the 'startVoting' field of 'ProposalThresholds'.
-- 2. The proposal's current time ensures 'isDraftPeriod'.
--
-- === @'VotingReady' -> 'Locked'@:
--
-- 1. The sum of all votes is larger than 'countVoting'.
-- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
-- 3. The proposal hasn't been alive for longer than the voting time.
-- 3. The proposal's current time ensures 'isVotingPeriod'.
--
-- === @'Locked' -> 'Finished'@:
--
-- Always valid provided the conditions for the transition are met.
-- 1. The proposal's current time ensures 'isExecutionPeriod'.
-- 2. The transaction mints the GATs to the receiving effects.
--
-- === @* -> 'Finished'@:
--
@ -424,6 +431,6 @@ proposalDatumValid proposal =
(#&&)
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
, ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
, ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
, ptraceIfFalse "Proposal votes and effects are compatible with eachother" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
, ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
, ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
]

110
agora/Agora/Proposal/Scripts.hs
View file

@ -20,7 +20,9 @@ import Agora.Stake (findStakeOwnedBy)
import Agora.Utils (
anyOutput,
findTxOutByTxOutRef,
getMintingPolicySymbol,
passert,
pisUniq,
psymbolValueOf,
ptokenSpent,
ptxSignedBy,
@ -32,8 +34,6 @@ import Plutarch.Api.V1 (
PScriptPurpose (PMinting, PSpending),
PTxInfo (PTxInfo),
PValidator,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Monadic qualified as P
@ -41,12 +41,22 @@ import Plutarch.TryFrom (ptryFrom)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
{- | Policy for Proposals.
This needs to perform two checks:
- Governor is happy with mint.
- Exactly 1 token is minted.
NOTE: The governor needs to check that the datum is correct
and sent to the right address.
== What this policy does
=== For minting:
- Governor is happy with mint.
* The governor must do most of the checking for the validity of the
transaction. For example, the governor must check that the datum
is correct, and that the ST is correctly paid to the right validator.
- Exactly 1 token is minted.
=== For burning:
- This policy cannot be burned.
-}
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
proposalPolicy proposal =
@ -62,7 +72,10 @@ proposalPolicy proposal =
AssetClass (govCs, govTn) = proposal.governorSTAssetClass
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
let mintedProposalST =
passetClassValueOf
# mintedValue
# (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
passert "Governance state-thread token must move" $
ptokenSpent
@ -74,7 +87,32 @@ proposalPolicy proposal =
popaque (pconstant ())
-- | Validator for Proposals.
{- | The validator for Proposals.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
== What this validator does
=== Voting/unlocking
When voting and unlocking, the proposal must witness a state transition
occuring in the relevant Stake. This transition must place a lock on
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
=== Periods
Most redeemers are time-sensitive.
A list of all time-sensitive redeemers and their requirements:
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
and 'Agora.Proposal.Time.isVotingPeriod' is true.
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
and 'Agora.Proposal.Time.isDraftPeriod' is true.
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
(see 'Agora.Proposal.AdvanceProposal' docs).
- 'Agora.Proposal.Unlock' is always valid.
-}
proposalValidator :: Proposal -> ClosedTerm PValidator
proposalValidator proposal =
plam $ \datum redeemer ctx' -> P.do
@ -88,8 +126,10 @@ proposalValidator proposal =
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- pletFields @'["address", "value"] $ txOut
(pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum
(pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer
(pfromData -> proposalDatum, _) <-
ptryFrom @(PAsData PProposalDatum) datum
(pfromData -> proposalRedeemer, _) <-
ptryFrom @(PAsData PProposalRedeemer) redeemer
proposalF <-
pletFields
@ -104,27 +144,30 @@ proposalValidator proposal =
ownAddress <- plet $ txOutF.address
stCurrencySymbol <- plet $ pconstant $ Plutarch.Api.V1.mintingPolicySymbol $ Plutarch.Api.V1.mkMintingPolicy (proposalPolicy proposal)
let stCurrencySymbol =
pconstant $ getMintingPolicySymbol (proposalPolicy proposal)
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn
spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
stakeSTAssetClass <-
plet $ passetClass # pconstant stakeSym # pconstant stakeTn
spentStakeST <-
plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
signedBy <- plet $ ptxSignedBy # txInfoF.signatories
passert "ST at inputs must be 1" $
spentST #== 1
pmatch proposalRedeemer $ \case
PVote _r -> P.do
passert "ST at inputs must be 1" $
spentST #== 1
popaque (pconstant ())
--------------------------------------------------------------------------
PCosign r -> P.do
newSigs <- plet $ pfield @"newCosigners" # r
passert "ST at inputs must be 1" $
spentST #== 1
passert "Cosigners are unique" $
pisUniq # newSigs
passert "Signed by all new cosigners" $
pall # signedBy # newSigs
@ -136,9 +179,15 @@ proposalValidator proposal =
pall
# plam
( \sig ->
pmatch (findStakeOwnedBy # stakeSTAssetClass # pfromData sig # txInfoF.datums # txInfoF.inputs) $ \case
PNothing -> pcon PFalse
PJust _ -> pcon PTrue
pmatch
( findStakeOwnedBy # stakeSTAssetClass
# pfromData sig
# txInfoF.datums
# txInfoF.inputs
)
$ \case
PNothing -> pcon PFalse
PJust _ -> pcon PTrue
)
# newSigs
@ -146,7 +195,8 @@ proposalValidator proposal =
anyOutput @PProposalDatum # ctx.txInfo
#$ plam
$ \newValue address newProposalDatum -> P.do
let correctDatum =
let updatedSigs = pconcat # newSigs # proposalF.cosigners
correctDatum =
pdata newProposalDatum
#== pdata
( mkRecordConstr
@ -154,7 +204,7 @@ proposalValidator proposal =
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
.& #cosigners .= pdata updatedSigs
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
)
@ -164,20 +214,16 @@ proposalValidator proposal =
(#&&)
[ pcon PTrue
, ptraceIfFalse "Datum must be correct" correctDatum
, ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
, ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
, ptraceIfFalse "Value should be correct" $
pdata txOutF.value #== pdata newValue
, ptraceIfFalse "Must be sent to Proposal's address" $
ownAddress #== pdata address
]
popaque (pconstant ())
--------------------------------------------------------------------------
PUnlock _r -> P.do
passert "ST at inputs must be 1" $
spentST #== 1
popaque (pconstant ())
--------------------------------------------------------------------------
PAdvanceProposal _r -> P.do
passert "ST at inputs must be 1" $
spentST #== 1
popaque (pconstant ())

76
agora/Agora/Proposal/Time.hs
View file

@ -19,12 +19,12 @@ module Agora.Proposal.Time (
PProposalTimingConfig (..),
PProposalStartingTime (..),
-- * Compute ranges given config and starting time.
-- * Compute periods given config and starting time.
currentProposalTime,
isDraftRange,
isVotingRange,
isLockingRange,
isExecutionRange,
isDraftPeriod,
isVotingPeriod,
isLockingPeriod,
isExecutionPeriod,
) where
import Agora.Record (mkRecordConstr, (.&), (.=))
@ -58,14 +58,14 @@ import Prelude hiding ((+))
For the purposes of proposals, there's a single most important feature:
The ability to determine if we can perform an action. In order to correctly
determine if we are able to perform certain actions, we need to know what
time it roughly is, compared to when the proposal got created.
time it roughly is, compared to when the proposal was created.
'ProposalTime' represents "the time according to the proposal".
Its representation is opaque, and doesn't matter.
Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'.
In particular, 'currentProposalTime' is useful for extracting the time
from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field
from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
of 'Plutus.V1.Ledger.Api.TxInfo'.
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
@ -153,7 +153,7 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field.
-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
currentProposalTime = phoistAcyclic $
plam $ \iv -> P.do
@ -179,7 +179,14 @@ currentProposalTime = phoistAcyclic $
)
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)
proposalTimeWithin ::
Term
s
( PPOSIXTime
:--> PPOSIXTime
:--> PProposalTime
:--> PBool
)
proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> P.do
PProposalTime proposalTime <- pmatch proposalTime'
@ -195,28 +202,61 @@ proposalTimeWithin = phoistAcyclic $
]
-- | True if the 'PProposalTime' is in the draft period.
isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
isDraftRange = phoistAcyclic $
isDraftPeriod ::
forall (s :: S).
Term
s
( PProposalTimingConfig
:--> PProposalStartingTime
:--> PProposalTime
:--> PBool
)
isDraftPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + pfield @"draftTime" # config)
-- | True if the 'PProposalTime' is in the voting period.
isVotingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
isVotingRange = phoistAcyclic $
isVotingPeriod ::
forall (s :: S).
Term
s
( PProposalTimingConfig
:--> PProposalStartingTime
:--> PProposalTime
:--> PBool
)
isVotingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
-- | True if the 'PProposalTime' is in the locking period.
isLockingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
isLockingRange = phoistAcyclic $
isLockingPeriod ::
forall (s :: S).
Term
s
( PProposalTimingConfig
:--> PProposalStartingTime
:--> PProposalTime
:--> PBool
)
isLockingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
-- | True if the 'PProposalTime' is in the execution period.
isExecutionRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
isExecutionRange = phoistAcyclic $
isExecutionPeriod ::
forall (s :: S).
Term
s
( PProposalTimingConfig
:--> PProposalStartingTime
:--> PProposalTime
:--> PBool
)
isExecutionPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
proposalTimeWithin # s
# (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)

61
agora/Agora/Stake/Scripts.hs
View file

@ -65,7 +65,10 @@ import Prelude hiding (Num (..))
- Check that exactly one state thread is burned.
- Check that datum at state thread is valid and not locked.
-}
stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
stakePolicy ::
-- | The (governance) token that a Stake can store.
Tagged GTTag AssetClass ->
ClosedTerm PMintingPolicy
stakePolicy gtClassRef =
plam $ \_redeemer ctx' -> P.do
ctx <- pletFields @'["txInfo", "purpose"] ctx'
@ -157,7 +160,59 @@ stakePolicy gtClassRef =
--------------------------------------------------------------------------------
-- | Validator intended for Stake UTXOs to live in.
-- | Validator intended for Stake UTXOs to be locked by.
--
--
-- == What this Validator does:
--
-- === 'DepositWithdraw'
--
-- Deposit or withdraw some GT to the stake.
--
-- - Tx must be signed by the owner.
-- - The 'stakedAmount' field must be updated.
-- - The stake must not be locked.
-- - The new UTXO must have the previous value plus the difference
-- as stated by the redeemer.
--
-- === 'PermitVote'
--
-- Allow a 'ProposalLock' to be put on the stake in order to vote
-- on a proposal.
--
-- - A proposal token must be spent alongside the stake.
--
-- * Its total votes must be correctly updated to include this stake's
-- contribution.
--
-- - Tx must be signed by the owner.
--
--
-- === 'RetractVotes'
--
-- Remove a 'ProposalLock' set when voting on a proposal.
--
-- - A proposal token must be spent alongside the stake.
-- - Tx must be signed by the owner.
--
--
-- === 'Destroy'
--
-- Destroy the stake in order to reclaim the min ADA.
--
-- - The stake must not be locked.
-- - Tx must be signed by the owner.
--
--
-- === 'WitnessStake'
--
-- Allow this Stake to be included in a transaction without making
-- any changes to it. In the future,
-- this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
--
-- - Tx must be signed by the owner __or__ a proposal ST token must be spent
-- alongside the stake.
-- - The datum and value must remain unchanged.
stakeValidator :: Stake -> ClosedTerm PValidator
stakeValidator stake =
plam $ \datum redeemer ctx' -> P.do
@ -243,8 +298,6 @@ stakeValidator stake =
"Owner signs this transaction"
ownerSignsTransaction
passert "ST at inputs must be 1" $
spentST #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.

40
agora/Agora/Utils.hs
View file

@ -28,6 +28,8 @@ module Agora.Utils (
pisJust,
ptokenSpent,
pkeysEqual,
pnub,
pisUniq,
-- * Functions which should (probably) not be upstreamed
anyOutput,
@ -38,6 +40,7 @@ module Agora.Utils (
findOutputsToAddress,
findTxOutDatum,
validatorHashToTokenName,
getMintingPolicySymbol,
) where
--------------------------------------------------------------------------------
@ -54,6 +57,7 @@ import Plutarch.Api.V1 (
PDatumHash,
PMap,
PMaybeData (PDJust),
PMintingPolicy,
PPubKeyHash,
PTokenName (PTokenName),
PTuple,
@ -63,6 +67,8 @@ import Plutarch.Api.V1 (
PTxOutRef,
PValidatorHash,
PValue,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.AssocMap (PMap (PMap))
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
@ -72,6 +78,7 @@ import Plutarch.Internal (punsafeCoerce)
import Plutarch.Map.Extra (pkeys)
import Plutarch.Monadic qualified as P
import Plutarch.TryFrom (PTryFrom, ptryFrom)
import Plutus.V1.Ledger.Api (CurrencySymbol)
--------------------------------------------------------------------------------
-- Validator-level utility functions
@ -88,7 +95,7 @@ pfindDatum = phoistAcyclic $
-- | Find a datum with the given hash, and `ptryFrom` it.
ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
ptryFindDatum = phoistAcyclic $
plam $ \datumHash inputs -> P.do
plam $ \datumHash inputs ->
pmatch (pfindDatum # datumHash # inputs) $ \case
PNothing -> pcon PNothing
PJust datum -> P.do
@ -330,6 +337,30 @@ pkeysEqual = phoistAcyclic $
pall # plam (\pk -> pelem # pk # qks) # pks
#&& pall # plam (\qk -> pelem # qk # pks) # 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)
-- | / 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)
)
(const $ pcon PTrue)
--------------------------------------------------------------------------------
{- Functions which should (probably) not be upstreamed
All of these functions are quite inefficient.
@ -447,5 +478,12 @@ findTxOutDatum = phoistAcyclic $
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
_ -> pcon PNothing
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety.
-}
validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
validatorHashToTokenName vh = pcon (PTokenName (pto vh))
-- | Get the CurrencySymbol of a PMintingPolicy.
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v