diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 69ddc1c..a4e3782 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -23,11 +23,11 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) helper. -} makeEffect :: - forall (datum :: PType) (s :: S). + forall (datum :: PType). PIsData datum => CurrencySymbol -> - (Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> - Term s PValidator + (forall (s :: S). Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> + ClosedTerm PValidator makeEffect gatCs' f = plam $ \datum _redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -40,7 +40,7 @@ makeEffect gatCs' f = txOutRef' <- plet (pfield @"_0" # txOutRef) txInfo <- pletFields @'["mint"] txInfo' - let mint :: Term s PValue + let mint :: Term _ PValue mint = txInfo.mint gatCs <- plet $ pconstant gatCs' diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index f063b6d..f8a9357 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -24,6 +24,10 @@ module Agora.Proposal ( PProposalVotes (..), PProposalTag (..), PResultTag (..), + + -- * Scripts + proposalValidator, + proposalPolicy, ) where import GHC.Generics qualified as GHC @@ -31,19 +35,25 @@ import Generics.SOP (Generic, I (I)) import Plutarch.Api.V1 ( PDatumHash, PMap, + PMintingPolicy, PPubKeyHash, + PValidator, PValidatorHash, ) import Plutarch.DataRepr ( + DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (PIsDataReprInstances), ) import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash) import PlutusTx qualified +import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) +import Plutarch (popaque) +import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) import Plutarch.SafeMoney (PDiscrete, Tagged) -------------------------------------------------------------------------------- @@ -57,7 +67,7 @@ import Plutarch.SafeMoney (PDiscrete, Tagged) @ -} newtype ResultTag = ResultTag {getResultTag :: Integer} - deriving stock (Eq, Show) + deriving stock (Eq, Show, Ord) deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) {- | The "status" of the proposal. This is only useful for state transitions, @@ -123,7 +133,7 @@ PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)] @[('ResultTag' 0, n), ('ResultTag' 1, m)]@ -} newtype ProposalVotes = ProposalVotes - { getProposalVotes :: [(ResultTag, Integer)] + { getProposalVotes :: AssocMap.Map ResultTag Integer } deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) @@ -163,10 +173,22 @@ data Proposal = Proposal newtype PResultTag (s :: S) = PResultTag (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger) +instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag +deriving via + (DerivePConstantViaNewtype ResultTag PResultTag PInteger) + instance + (PConstant ResultTag) + -- | Plutarch-level version of 'PProposalTag'. newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger) +instance PUnsafeLiftDecl PProposalTag where type PLifted PProposalTag = ProposalTag +deriving via + (DerivePConstantViaNewtype ProposalTag PProposalTag PInteger) + instance + (PConstant ProposalTag) + -- | Plutarch-level version of 'ProposalStatus'. data PProposalStatus (s :: S) = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'. @@ -181,6 +203,9 @@ data PProposalStatus (s :: S) (PlutusType, PIsData) via PIsDataReprInstances PProposalStatus +instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus +deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus) + -- | Plutarch-level version of 'ProposalThresholds'. newtype PProposalThresholds (s :: S) = PProposalThresholds { getProposalThresholds :: @@ -200,11 +225,20 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalThresholds) +instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds +deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds) + -- | Plutarch-level version of 'ProposalVotes'. newtype PProposalVotes (s :: S) = PProposalVotes (Term s (PMap PResultTag PInteger)) deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger)) +instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes +deriving via + (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger)) + instance + (PConstant ProposalVotes) + -- | Plutarch-level version of 'ProposalDatum'. newtype PProposalDatum (s :: S) = PProposalDatum { getProposalDatum :: @@ -225,3 +259,20 @@ newtype PProposalDatum (s :: S) = PProposalDatum deriving (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalDatum) + +instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum +deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum) + +-------------------------------------------------------------------------------- + +-- | Policy for Proposals. +proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy +proposalPolicy _ = + plam $ \_redeemer _ctx' -> P.do + popaque (pconstant ()) + +-- | Validator for Proposals. +proposalValidator :: Proposal -> ClosedTerm PValidator +proposalValidator _ = + plam $ \_datum _redeemer _ctx' -> P.do + popaque (pconstant ()) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 814b2f2..7a90877 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -63,11 +63,11 @@ import Agora.Utils ( anyOutput, paddValue, passert, - passetClassValueOf', pfindTxInByTxOutRef, pgeqByClass, pgeqByClass', pgeqBySymbol, + pnotNull, psingletonValue, psymbolValueOf, ptxSignedBy, @@ -89,27 +89,72 @@ newtype Stake = Stake -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. } --- | Haskell-level redeemer for Stake scripts. -data StakeRedeemer - = -- | Deposit or withdraw a discrete amount of the staked governance token. - DepositWithdraw (Tagged GTTag Integer) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. - Destroy - deriving stock (Show, GHC.Generic) +{- | A lock placed on a Stake datum in order to prevent + depositing and withdrawing when votes are in place. -PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] + NOTE: Due to retracting votes always being possible, + this lock will only lock with contention on the proposal. + FIXME: Contention on Proposals could create contention + on voting which in turn creates contention on stakers. + + Vaguely this is the dependency graph for this locking + interaction. Both the stake vaalidator and the proposal + validator are only able to check for eachother through + the datum belonging to the ST: + + @ + ┌─────────────────┐ ┌────────────────────┐ + │ Stake Validator ├─┐ │ Proposal Validator │ + └────────┬────────┘ │ └──────┬─────┬───────┘ + │ │ │ │ + │ ┌─┼────────┘ │ + ▼ │ │ ▼ + ┌──────────────┐ │ │ ┌─────────────────┐ + │ Stake Policy │◄─┘ └►│ Proposal Policy │ + └──────────────┘ └─────────────────┘ + @ +-} data ProposalLock = ProposalLock { vote :: ResultTag -- ^ What was voted on. This allows retracting votes to -- undo their vote. , proposalTag :: ProposalTag - -- ^ Identifies the proposal. + -- ^ Identifies the proposal. See 'ProposalTag' for further + -- comments on its significance. } deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)] +-- | Haskell-level redeemer for Stake scripts. +data StakeRedeemer + = -- | Deposit or withdraw a discrete amount of the staked governance token. + -- Stake must be unlocked. + DepositWithdraw (Tagged GTTag Integer) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. + -- Stake must be unlocked. + Destroy + | -- | Permit a Vote to be added onto a 'Proposal'. + -- This also adds a lock to the 'lockedBy' field. See 'ProposalLock'. + -- This needs to be done in sync with casting a vote, otherwise + -- it's possible for a lock to be permanently placed on the stake, + -- and then the funds are lost. + PermitVote ProposalLock + | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'. + -- This action checks for permission of the 'Proposal'. Finished proposals are + -- always allowed to be retracted with. + RetractVotes [ProposalLock] + deriving stock (Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed + ''StakeRedeemer + [ ('DepositWithdraw, 0) + , ('Destroy, 1) + , ('PermitVote, 2) + , ('RetractVotes, 3) + ] + -- | Haskell-level datum for Stake scripts. data StakeDatum = StakeDatum { stakedAmount :: Tagged GTTag Integer @@ -158,6 +203,8 @@ data PStakeRedeemer (s :: S) PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) | -- | 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])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) @@ -204,10 +251,7 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons -------------------------------------------------------------------------------- -- | Policy for Stake state threads. -stakePolicy :: - forall (s :: S). - Stake -> - Term s PMintingPolicy +stakePolicy :: Stake -> ClosedTerm PMintingPolicy stakePolicy stake = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -300,10 +344,7 @@ stakePolicy stake = -------------------------------------------------------------------------------- -- | Validator intended for Stake UTXOs to live in. -stakeValidator :: - forall (s :: S). - Stake -> - Term s PValidator +stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator stake = plam $ \datum redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -322,28 +363,48 @@ stakeValidator stake = PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo' ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo + + -- Whether the owner signs this transaction or not. ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake) mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo' + -- Is the stake currently locked? + stakeIsLocked <- plet $ stakeLocked # stakeDatum' + pmatch stakeRedeemer $ \case PDestroy _ -> P.do passert "ST at inputs must be 1" $ spentST #== 1 passert "Should burn ST" $ mintedST #== -1 - passert "Stake unlocked" $ - pnot #$ stakeLocked # stakeDatum' + passert "Stake unlocked" $ pnot # stakeIsLocked passert "Owner signs this transaction" ownerSignsTransaction popaque (pconstant ()) + -------------------------------------------------------------------------- + PRetractVotes _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- + PPermitVote _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- PDepositWithdraw r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 passert "Stake unlocked" $ - pnot #$ stakeLocked # stakeDatum' + pnot #$ stakeIsLocked passert "Owner signs this transaction" ownerSignsTransaction @@ -365,9 +426,6 @@ stakeValidator stake = ] let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta) - ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value) - ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # expectedValue) - -- TODO: Same as above. This is quite inefficient now, as it does two lookups -- instead of a more efficient single pass, -- but it doesn't really matter for this. At least it's correct. @@ -401,5 +459,4 @@ stakeLocked = phoistAcyclic $ plam $ \stakeDatum -> let locks :: Term _ (PBuiltinList (PAsData PProposalLock)) locks = pfield @"lockedBy" # stakeDatum - in -- 'pnotNull' ? - pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks + in pnotNull # locks diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index df11f65..9cbf6da 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -28,10 +28,8 @@ import Agora.Utils (passert) do so in a valid manner. -} treasuryV :: - forall {s :: S}. CurrencySymbol -> - Term - s + ClosedTerm ( PAsData PTreasuryDatum :--> PAsData PTreasuryRedeemer :--> PAsData PScriptContext @@ -50,7 +48,7 @@ treasuryV gatCs' = plam $ \_d r ctx' -> P.do -- Get the minted value from txInfo. txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint"] txInfo' - let mint :: Term s PValue + let mint :: Term _ PValue mint = txInfo.mint gatCs <- plet $ pconstant gatCs' diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 2f875b0..5ac101c 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -25,6 +25,7 @@ module Agora.Utils ( pfindTxInByTxOutRef, psingletonValue, pfindMap, + pnotNull, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -281,6 +282,10 @@ pfindTxInByTxOutRef = phoistAcyclic $ ) #$ (pfield @"inputs" # txInfo) +-- | True if a list is not empty. +pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool) +pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse) + -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed All of these functions are quite inefficient.