diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 08bd0e1..e62103e 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -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) } ] diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index eea1c0c..d4b6c4d 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -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. diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 8327d57..afaacb1 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -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, diff --git a/flake.lock b/flake.lock index 73e7d0d..0b23a54 100644 --- a/flake.lock +++ b/flake.lock @@ -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" } }, diff --git a/flake.nix b/flake.nix index 3b1756a..d51df25 100644 --- a/flake.nix +++ b/flake.nix @@ -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";