lock field in Stake datum, singleAuthorityTokenBurned helper
This commit is contained in:
Emily Martins
parent
097e055f19
commit
b0eb044bf2
7 changed files with 146 additions and 27 deletions
|
|
@ -95,7 +95,7 @@ stakeCreation :: ScriptContext
|
|||
stakeCreation =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
|
|
@ -123,7 +123,7 @@ stakeCreation =
|
|||
stakeCreationWrongDatum :: ScriptContext
|
||||
stakeCreationWrongDatum =
|
||||
let datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
|
||||
, scriptContextPurpose = Minting policySymbol
|
||||
|
|
@ -155,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
|
|||
stakeDepositWithdraw config =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
stakeBefore :: StakeDatum
|
||||
stakeBefore = StakeDatum config.startAmount signer
|
||||
stakeBefore = StakeDatum config.startAmount signer []
|
||||
|
||||
stakeAfter :: StakeDatum
|
||||
stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
|
||||
|
|
|
|||
|
|
@ -52,19 +52,19 @@ tests =
|
|||
, validatorSucceedsWith
|
||||
"stakeDepositWithdraw deposit"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
|
||||
, validatorSucceedsWith
|
||||
"stakeDepositWithdraw withdraw"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw $ negate 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
|
||||
, validatorFailsWith
|
||||
"stakeDepositWithdraw negative GT"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw 1_000_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
|
||||
]
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ Tokens acting as redeemable proofs of DAO authority.
|
|||
module Agora.AuthorityToken (
|
||||
authorityTokenPolicy,
|
||||
authorityTokensValidIn,
|
||||
singleAuthorityTokenBurned,
|
||||
AuthorityToken (..),
|
||||
) where
|
||||
|
||||
|
|
@ -32,7 +33,15 @@ import Prelude
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup)
|
||||
import Agora.Utils (
|
||||
allInputs,
|
||||
allOutputs,
|
||||
passert,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
plookup,
|
||||
psymbolValueOf,
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -85,6 +94,27 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
-- No GATs exist at this output!
|
||||
pconstant True
|
||||
|
||||
-- | Assert that a single authority token has been burned.
|
||||
singleAuthorityTokenBurned ::
|
||||
forall (s :: S).
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PAsData PTxInfo) ->
|
||||
Term s PValue ->
|
||||
Term s PBool
|
||||
singleAuthorityTokenBurned gatCs txInfo mint = P.do
|
||||
let gatAmountMinted :: Term _ PInteger
|
||||
gatAmountMinted = psymbolValueOf # gatCs # mint
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
|
||||
, ptraceIfFalse "All inputs only have valid GATs" $
|
||||
allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# gatCs
|
||||
# txOut
|
||||
]
|
||||
|
||||
-- | Policy given 'AuthorityToken' params.
|
||||
authorityTokenPolicy ::
|
||||
AuthorityToken ->
|
||||
|
|
|
|||
|
|
@ -7,19 +7,28 @@ Helpers for constructing effects.
|
|||
-}
|
||||
module Agora.Effect (makeEffect) where
|
||||
|
||||
import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator)
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Helper "template" for creating effect validator.
|
||||
{- | Helper "template" for creating effect validator.
|
||||
|
||||
In some situations, it may be the case that we need more control over how
|
||||
an effect is implemented. In such situations, it's okay to not use this
|
||||
helper.
|
||||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType) (s :: S).
|
||||
PIsData datum =>
|
||||
(Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) ->
|
||||
CurrencySymbol ->
|
||||
(Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
Term s PValidator
|
||||
makeEffect f =
|
||||
makeEffect gatCs' f =
|
||||
plam $ \datum _redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
|
@ -30,7 +39,13 @@ makeEffect f =
|
|||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
txOutRef' <- plet (pfield @"_0" # txOutRef)
|
||||
|
||||
-- TODO: Here, check that a *single* GAT is burned.
|
||||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term s PValue
|
||||
mint = txInfo.mint
|
||||
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
f datum' txOutRef' txInfo'
|
||||
|
||||
|
|
|
|||
|
|
@ -14,10 +14,15 @@ module Agora.Proposal (
|
|||
ProposalStatus (..),
|
||||
ProposalThresholds (..),
|
||||
ProposalVotes (..),
|
||||
ProposalTag (..),
|
||||
ResultTag (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalDatum (..),
|
||||
PProposalStatus (..),
|
||||
PProposalThresholds (..),
|
||||
PProposalVotes (..),
|
||||
PProposalTag (..),
|
||||
PResultTag (..),
|
||||
) where
|
||||
|
||||
|
|
@ -85,6 +90,7 @@ data ProposalStatus
|
|||
--
|
||||
-- TODO: The owner of the proposal may choose to reclaim their proposal.
|
||||
Finished
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
|
||||
|
||||
|
|
@ -101,6 +107,7 @@ data ProposalThresholds = ProposalThresholds
|
|||
-- ^ How much GT required to allow voting to happen.
|
||||
-- (i.e. to move into 'VotingReady')
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
|
||||
|
||||
|
|
@ -119,6 +126,7 @@ newtype ProposalVotes = ProposalVotes
|
|||
{ getProposalVotes :: [(ResultTag, Integer)]
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Haskell-level datum for Proposal scripts.
|
||||
data ProposalDatum = ProposalDatum
|
||||
|
|
@ -136,9 +144,15 @@ data ProposalDatum = ProposalDatum
|
|||
, votes :: ProposalVotes
|
||||
-- ^ Vote tally on the proposal
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
|
||||
|
||||
-- | Identifies a Proposal, issued upon creation of a proposal.
|
||||
newtype ProposalTag = ProposalTag {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Parameters that identify the Proposal validator script.
|
||||
data Proposal = Proposal
|
||||
|
||||
|
|
@ -149,6 +163,10 @@ data Proposal = Proposal
|
|||
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
|
||||
|
||||
-- | Plutarch-level version of 'PProposalTag'.
|
||||
newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStatus'.
|
||||
data PProposalStatus (s :: S)
|
||||
= -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
|
||||
|
|
|
|||
|
|
@ -12,6 +12,8 @@ module Agora.Stake (
|
|||
PStakeRedeemer (..),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
ProposalLock (..),
|
||||
PProposalLock (..),
|
||||
Stake (..),
|
||||
stakePolicy,
|
||||
stakeValidator,
|
||||
|
|
@ -43,15 +45,18 @@ import Plutarch.Api.V1 (
|
|||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
|
|
@ -94,19 +99,48 @@ data StakeRedeemer
|
|||
|
||||
PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
|
||||
|
||||
data ProposalLock = ProposalLock
|
||||
{ vote :: ResultTag
|
||||
-- ^ What was voted on. This allows retracting votes to
|
||||
-- undo their vote.
|
||||
, proposalTag :: ProposalTag
|
||||
-- ^ Identifies the proposal.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]
|
||||
|
||||
-- | Haskell-level datum for Stake scripts.
|
||||
data StakeDatum = StakeDatum
|
||||
{ stakedAmount :: Tagged GTTag Integer
|
||||
-- ^ Tracks the amount of governance token staked in the datum.
|
||||
-- This also acts as the voting weight for 'Proposal's.
|
||||
, owner :: PubKeyHash
|
||||
-- ^ The hash of the public key this stake belongs to.
|
||||
--
|
||||
-- TODO Support for MultiSig/Scripts is tracked here:
|
||||
-- https://github.com/Liqwid-Labs/agora/issues/45
|
||||
, lockedBy :: [ProposalLock]
|
||||
-- ^ The proposal locks in place. This field must be empty
|
||||
-- for the stake to be usable for deposits and withdrawals.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Plutarch-level datum for Stake scripts.
|
||||
newtype PStakeDatum (s :: S) = PStakeDatum
|
||||
{ getStakeDatum ::
|
||||
Term s (PDataRecord '["stakedAmount" ':= PDiscrete GTTag, "owner" ':= PPubKeyHash])
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -115,6 +149,9 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (s :: S)
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
|
|
@ -128,6 +165,29 @@ data PStakeRedeemer (s :: S)
|
|||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
|
||||
|
||||
newtype PProposalLock (s :: S) = PProposalLock
|
||||
{ getProposalLock ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "vote" ':= PResultTag
|
||||
, "proposalTag" ':= PProposalTag
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- What this Policy does
|
||||
|
||||
|
|
@ -338,6 +398,8 @@ stakeValidator stake =
|
|||
-- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
|
||||
stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
|
||||
stakeLocked = phoistAcyclic $
|
||||
plam $ \_stakeDatum ->
|
||||
-- TODO: when we extend this to support proposals, this will need to do something
|
||||
pcon PFalse
|
||||
plam $ \stakeDatum ->
|
||||
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
|
||||
locks = pfield @"lockedBy" # stakeDatum
|
||||
in -- 'pnotNull' ?
|
||||
pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (authorityTokensValidIn)
|
||||
import Agora.Utils (allInputs, passert, psymbolValueOf)
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
|
||||
{- | Validator ensuring that transactions consuming the treasury
|
||||
do so in a valid manner.
|
||||
|
|
@ -37,7 +37,7 @@ treasuryV ::
|
|||
:--> PAsData PScriptContext
|
||||
:--> PUnit
|
||||
)
|
||||
treasuryV cs = plam $ \_d r ctx' -> P.do
|
||||
treasuryV gatCs' = plam $ \_d r ctx' -> P.do
|
||||
-- plet required fields from script context.
|
||||
ctx <- pletFields @["txInfo", "purpose"] ctx'
|
||||
|
||||
|
|
@ -52,16 +52,10 @@ treasuryV cs = plam $ \_d r ctx' -> P.do
|
|||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term s PValue
|
||||
mint = txInfo.mint
|
||||
gatAmountMinted :: Term s PInteger
|
||||
gatAmountMinted = psymbolValueOf # pconstant cs # mint
|
||||
|
||||
passert "GAT not burned." $ gatAmountMinted #== -1
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "All inputs only have valid GATs" $
|
||||
allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# pconstant cs
|
||||
# txOut
|
||||
passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
pconstant ()
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue