add locks in datums, add documentation, ClosedTerm on scripts
Also added more lifting instances
This commit is contained in:
Emily Martins
parent
86287a257d
commit
4ef7c7866c
5 changed files with 147 additions and 36 deletions
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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 ())
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue