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

add ProposalRedeemer, bump plutarch-safemoney PR revision

Browse source
This commit is contained in:
Emily Martins 2022-04-15 22:03:18 +02:00
parent 2726348665
commit 8f8416593f
5 changed files with 122 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

3
agora-test/Spec/Sample/Stake.hs
View file

@ -177,8 +177,7 @@ stakeDepositWithdraw config =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutValue =
st
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]

102
agora/Agora/Proposal.hs
View file

@ -57,12 +57,14 @@ import PlutusTx.AssocMap qualified as AssocMap
import Agora.SafeMoney (GTTag)
import Agora.Utils (passert, pnotNull, ptokenSpent)
import Control.Arrow (first)
import Plutarch (popaque)
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Builtin (PBuiltinMap)
import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (PDiscrete, Tagged)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
@ -102,26 +104,33 @@ data ProposalStatus
-- This means that once the timing requirements align,
-- proposal will be able to be voted on.
VotingReady
| -- | The proposal has been voted on, and the votes have been locked
-- permanently. The proposal can now be executed.
Voted
| -- | The proposal has finished.
--
-- This can mean it's been voted on and completed, but it can also mean
-- the proposal failed due to time constraints or didn't
-- the proposal failed due to time constraints or didn't
-- get to 'VotingReady' first.
--
-- At this stage, the 'votes' field of 'ProposalState' is frozen.
--
-- See 'AdvanceProposal' for documentation on state transitions.
--
-- 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)]
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Voted, 2), ('Finished, 3)]
{- | The threshold values for various state transitions to happen.
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
to 'Proposal's when they are created.
-}
data ProposalThresholds = ProposalThresholds
{ execute :: Tagged GTTag Integer
{ countVoting :: Tagged GTTag Integer
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
, draft :: Tagged GTTag Integer
, create :: Tagged GTTag Integer
-- ^ How much GT required to "create" a proposal.
, vote :: Tagged GTTag Integer
-- ^ How much GT required to allow voting to happen.
@ -168,6 +177,49 @@ data ProposalDatum = ProposalDatum
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
-- | Haskell-level redeemer for Proposal scripts.
data ProposalRedeemer
= -- | Cast one or more votes towards a particular 'ResultTag'.
Vote ResultTag
| -- | Add one or more public keys to the cosignature list. Must be signed by
-- those cosigning.
--
-- This is particularly used in the 'Draft' 'ProposalStatus'. Where matching
-- 'Stake's can be called to advance the proposal, provided enough GT is shared
-- among them.
Cosign [PubKeyHash]
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
Unlock ResultTag
| -- | Advance the proposal, performing the required checks for whether that is legal.
--
-- These are roughly the checks for each possible transition:
--
-- @'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.
--
-- @'VotingReady' -> 'Voted'@:
-- 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.
--
-- @'Voted' -> 'Finished'@:
-- Always valid provided the conditions for the transition are met.
--
-- @* -> 'Finished'@:
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
-- to transition into 'Finished' state, because it has expired (and failed).
AdvanceProposal
deriving stock (Eq, Show, GHC.Generic)
PlutusTx.makeIsDataIndexed
''ProposalRedeemer
[ ('Vote, 0)
, ('Cosign, 1)
, ('Unlock, 2)
, ('AdvanceProposal, 3)
]
{- | 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@.
@ -196,10 +248,30 @@ deriving via
instance
(PConstant ResultTag)
-- FIXME: This instance and the one below, for 'PProposalId', should be derived.
-- Soon this will be possible through 'DerivePNewtype'.
instance PTryFrom PData (PAsData PResultTag) where
type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k =
ptryFrom' @_ @(PAsData PInteger) d $
-- JUSTIFICATION:
-- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
-- Since 'PTagged' is a simple newtype, their shape is the same.
k . first punsafeCoerce
-- | Plutarch-level version of 'PProposalId'.
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
instance PTryFrom PData (PAsData PProposalId) where
type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k =
ptryFrom' @_ @(PAsData PInteger) d $
-- JUSTIFICATION:
-- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
-- Since 'PTagged' is a simple newtype, their shape is the same.
k . first punsafeCoerce
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
deriving via
(DerivePConstantViaNewtype ProposalId PProposalId PInteger)
@ -280,6 +352,28 @@ newtype PProposalDatum (s :: S) = PProposalDatum
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
-- | Haskell-level redeemer for Proposal scripts.
data PProposalRedeemer (s :: S)
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
| PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData)
via PIsDataReprInstances PProposalRedeemer
-- TODO: Waiting on PTryFrom for 'PPubKeyHash'
-- deriving via
-- PAsData (PIsDataReprInstances PProposalRedeemer)
-- instance
-- PTryFrom PData (PAsData PProposalRedeemer)
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstant ProposalRedeemer)
--------------------------------------------------------------------------------
{- | Policy for Proposals.

25
agora/Agora/Stake.hs
View file

@ -77,9 +77,10 @@ import Plutarch.Numeric
import Plutarch.SafeMoney (
PDiscrete,
Tagged (..),
pdiscreteValue,
pdiscreteValue',
untag,
)
import Plutarch.TryFrom (PTryFrom, ptryFrom)
--------------------------------------------------------------------------------
@ -205,7 +206,7 @@ data PStakeRedeemer (s :: S)
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
PDestroy (Term s (PDataRecord '[]))
| PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock]))
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
@ -213,6 +214,11 @@ data PStakeRedeemer (s :: S)
(PlutusType, PIsData)
via PIsDataReprInstances PStakeRedeemer
deriving via
PAsData (PIsDataReprInstances PStakeRedeemer)
instance
PTryFrom PData (PAsData PStakeRedeemer)
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
@ -233,6 +239,11 @@ newtype PProposalLock (s :: S) = PProposalLock
(PlutusType, PIsData, PDataFields)
via (PIsDataReprInstances PProposalLock)
deriving via
PAsData (PIsDataReprInstances PProposalLock)
instance
PTryFrom PData (PAsData PProposalLock)
instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
@ -312,7 +323,7 @@ stakePolicy stake =
# 1
let expectedValue =
paddValue
# (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
# (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount)
# stValue
let ownerSignsTransaction =
ptxSignedBy
@ -352,10 +363,10 @@ stakeValidator stake =
txInfo' <- plet ctx.txInfo
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
(pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
-- TODO: Use PTryFrom
let stakeRedeemer :: Term _ PStakeRedeemer
stakeRedeemer = pfromData $ punsafeCoerce redeemer
stakeDatum' :: Term _ PStakeDatum
let stakeDatum' :: Term _ PStakeDatum
stakeDatum' = pfromData $ punsafeCoerce datum
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
@ -425,7 +436,7 @@ stakeValidator stake =
-- do we need to check this, really?
zero #<= pfromData newStakeDatum.stakedAmount
]
let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
-- instead of a more efficient single pass,

8
flake.lock generated
View file

@ -1621,17 +1621,17 @@
"validity": "validity"
},
"locked": {
"lastModified": 1648639396,
"narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
"lastModified": 1650025193,
"narHash": "sha256-SXfkWYse308SdnWO34cMVjKliDvyYYx++Y5uiuUmGXE=",
"owner": "peter-mlabs",
"repo": "plutarch",
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
"rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
"type": "github"
},
"original": {
"owner": "peter-mlabs",
"repo": "plutarch",
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
"rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
"type": "github"
}
},

2
flake.nix
View file

@ -9,7 +9,7 @@
# Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
inputs.plutarch.url =
"github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
"github:peter-mlabs/plutarch?rev=18e787d420912ed765fc5653c3558f20ab5e638a";
inputs.plutarch.inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";