Merge pull request #149 from Liqwid-Labs/connor/stake-delegation
Stake delegation
This commit is contained in:
Emily
GitHub
commit
01f055d923
16 changed files with 980 additions and 591 deletions
|
|
@ -11,6 +11,10 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
|
|||
|
||||
### Modified
|
||||
|
||||
- Stake delegation.
|
||||
|
||||
Included by [#149](https://github.com/Liqwid-Labs/agora/pull/149).
|
||||
|
||||
- Fixed bug that checks the proposal thresholds in an incorrect way. Added negative tests for the governor scripts.
|
||||
|
||||
Included by [#146](https://github.com/Liqwid-Labs/agora/pull/146).
|
||||
|
|
|
|||
|
|
@ -352,6 +352,7 @@ mkStakeInputDatums ps =
|
|||
StakeDatum
|
||||
{ stakedAmount = Tagged ps.perStakeGTs
|
||||
, owner = ""
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = []
|
||||
}
|
||||
in (\owner -> template {owner = owner})
|
||||
|
|
|
|||
|
|
@ -130,7 +130,7 @@ mkProposalOutputDatum ps =
|
|||
|
||||
-- | Create all the input stakes given the parameters.
|
||||
mkStakeInputDatums :: Parameters -> [StakeDatum]
|
||||
mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk []) . newCosigners
|
||||
mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk Nothing []) . newCosigners
|
||||
|
||||
-- | Create a 'TxInfo' that tries to cosign a proposal with new cosigners.
|
||||
cosign :: forall b. CombinableBuilder b => Parameters -> b
|
||||
|
|
|
|||
|
|
@ -185,6 +185,7 @@ mkStakeInputDatum ps =
|
|||
in StakeDatum
|
||||
{ stakedAmount = stakedGTs
|
||||
, owner = stakeOwner
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = locks
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -177,6 +177,7 @@ mkStakeInputDatum ps =
|
|||
StakeDatum
|
||||
{ stakedAmount = defStakedGTs
|
||||
, owner = defOwner
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = mkInputStakeLocks ps
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ Sample and utilities for testing the functionalities of voting on proposals.
|
|||
module Sample.Proposal.Vote (
|
||||
validVoteParameters,
|
||||
mkTestTree,
|
||||
validVoteAsDelegateParameters,
|
||||
) where
|
||||
|
||||
import Agora.Proposal (
|
||||
|
|
@ -66,7 +67,7 @@ import Test.Specification (
|
|||
testValidator,
|
||||
validatorSucceedsWith,
|
||||
)
|
||||
import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, sortValue, updateMap)
|
||||
import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue, updateMap)
|
||||
|
||||
-- | Reference to the proposal UTXO.
|
||||
proposalRef :: TxOutRef
|
||||
|
|
@ -82,6 +83,8 @@ data Parameters = Parameters
|
|||
-- ^ The outcome the transaction is voting for.
|
||||
, voteCount :: Integer
|
||||
-- ^ The count of votes.
|
||||
, voteAsDelegate :: Bool
|
||||
-- ^ Delegate the stake and use it to vote.
|
||||
}
|
||||
|
||||
-- | The public key hash of the stake owner.
|
||||
|
|
@ -121,6 +124,9 @@ existingLocks =
|
|||
, Voted (ProposalId 1) (ResultTag 2)
|
||||
]
|
||||
|
||||
delegate :: PubKeyHash
|
||||
delegate = head pubKeyHashes
|
||||
|
||||
{- | Set the 'StakeDatum.stakedAmount' according to the number of votes being
|
||||
casted.
|
||||
-}
|
||||
|
|
@ -129,6 +135,10 @@ mkStakeInputDatum params =
|
|||
StakeDatum
|
||||
{ stakedAmount = Tagged params.voteCount
|
||||
, owner = stakeOwner
|
||||
, delegatedTo =
|
||||
if params.voteAsDelegate
|
||||
then Just delegate
|
||||
else Nothing
|
||||
, lockedBy = existingLocks
|
||||
}
|
||||
|
||||
|
|
@ -198,10 +208,15 @@ vote params =
|
|||
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
|
||||
<> minAda
|
||||
|
||||
signer =
|
||||
if params.voteAsDelegate
|
||||
then delegate
|
||||
else stakeOwner
|
||||
|
||||
builder =
|
||||
mconcat
|
||||
[ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
|
||||
, signedWith stakeOwner
|
||||
, signedWith signer
|
||||
, timeRange validTimeRange
|
||||
, input $
|
||||
script proposalValidatorHash
|
||||
|
|
@ -232,6 +247,13 @@ validVoteParameters =
|
|||
Parameters
|
||||
{ voteFor = ResultTag 0
|
||||
, voteCount = 27
|
||||
, voteAsDelegate = False
|
||||
}
|
||||
|
||||
validVoteAsDelegateParameters :: Parameters
|
||||
validVoteAsDelegateParameters =
|
||||
validVoteParameters
|
||||
{ voteAsDelegate = True
|
||||
}
|
||||
|
||||
---
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ stakeCreation :: ScriptContext
|
|||
stakeCreation =
|
||||
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
|
||||
datum :: StakeDatum
|
||||
datum = StakeDatum 424242424242 signer []
|
||||
datum = StakeDatum 424242424242 signer Nothing []
|
||||
|
||||
builder :: MintingBuilder
|
||||
builder =
|
||||
|
|
@ -96,7 +96,7 @@ stakeCreation =
|
|||
stakeCreationWrongDatum :: ScriptContext
|
||||
stakeCreationWrongDatum =
|
||||
let datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer Nothing []) -- Too much GT
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
|
|
@ -128,7 +128,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
|
|||
stakeDepositWithdraw config =
|
||||
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
|
||||
stakeBefore :: StakeDatum
|
||||
stakeBefore = StakeDatum config.startAmount signer []
|
||||
stakeBefore = StakeDatum config.startAmount signer Nothing []
|
||||
|
||||
stakeAfter :: StakeDatum
|
||||
stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
|
||||
|
|
|
|||
204
agora-specs/Sample/Stake/SetDelegate.hs
Normal file
204
agora-specs/Sample/Stake/SetDelegate.hs
Normal file
|
|
@ -0,0 +1,204 @@
|
|||
{- |
|
||||
Module : Sample.Stake.SetDelegate
|
||||
Maintainer : connor@mlabs.city
|
||||
Description: Generate sample data for testing the functionalities of setting the delegate.
|
||||
|
||||
Sample and utilities for testing the functionalities of setting the delegate.
|
||||
-}
|
||||
module Sample.Stake.SetDelegate (
|
||||
Parameters (..),
|
||||
setDelegate,
|
||||
mkStakeRedeemer,
|
||||
mkStakeInputDatum,
|
||||
mkTestCase,
|
||||
overrideExistingDelegateParameters,
|
||||
clearDelegateParameters,
|
||||
setDelegateParameters,
|
||||
invalidOutputStakeDatumParameters,
|
||||
ownerDoesntSignParameters,
|
||||
delegateToOwnerParameters,
|
||||
) where
|
||||
|
||||
import Agora.Stake (
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (ClearDelegate, DelegateTo),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Tagged (untag)
|
||||
import Plutarch.Context (
|
||||
SpendingBuilder,
|
||||
buildSpendingUnsafe,
|
||||
input,
|
||||
output,
|
||||
script,
|
||||
signedWith,
|
||||
txId,
|
||||
withDatum,
|
||||
withOutRef,
|
||||
withSpendingOutRef,
|
||||
withValue,
|
||||
)
|
||||
import PlutusLedgerApi.V1 (
|
||||
PubKeyHash,
|
||||
ScriptContext,
|
||||
TxOutRef (TxOutRef),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (
|
||||
minAda,
|
||||
signer,
|
||||
signer2,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Test.Specification (SpecificationTree, testValidator)
|
||||
import Test.Util (pubKeyHashes, sortValue)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters that control the script context generation of 'setDelegate'.
|
||||
data Parameters = Parameters
|
||||
{ existingDelegate :: Maybe PubKeyHash
|
||||
-- ^ Whom the stake has been delegated to.
|
||||
, newDelegate :: Maybe PubKeyHash
|
||||
-- ^ The new delegate to set to.
|
||||
, invalidOutputStake :: Bool
|
||||
-- ^ The output stake datum will be invalid if this is set to true.
|
||||
, signedByOwner :: Bool
|
||||
-- ^ Whether the stake owner signs the transaction o not.
|
||||
}
|
||||
|
||||
-- | Select the correct stake redeemer based on the existence of the new delegate.
|
||||
mkStakeRedeemer :: Parameters -> StakeRedeemer
|
||||
mkStakeRedeemer (newDelegate -> d) = maybe ClearDelegate DelegateTo d
|
||||
|
||||
-- | The owner of the input stake.
|
||||
stakeOwner :: PubKeyHash
|
||||
stakeOwner = signer
|
||||
|
||||
-- | Create input stake datum given the parameters.
|
||||
mkStakeInputDatum :: Parameters -> StakeDatum
|
||||
mkStakeInputDatum ps =
|
||||
StakeDatum
|
||||
{ stakedAmount = 5
|
||||
, owner = stakeOwner
|
||||
, delegatedTo = ps.existingDelegate
|
||||
, lockedBy = []
|
||||
}
|
||||
|
||||
-- | Generate a 'ScriptContext' that tries to change the delegate of a stake.
|
||||
setDelegate :: Parameters -> ScriptContext
|
||||
setDelegate ps = buildSpendingUnsafe builder
|
||||
where
|
||||
stakeRef :: TxOutRef
|
||||
stakeRef = TxOutRef "0ffef57e30cc604342c738e31e0451593837b313e7bfb94b0922b142782f98e6" 1
|
||||
|
||||
stakeInput = mkStakeInputDatum ps
|
||||
|
||||
stakeOutput =
|
||||
let stakedAmount =
|
||||
if ps.invalidOutputStake
|
||||
then stakeInput.stakedAmount - 1
|
||||
else stakeInput.stakedAmount
|
||||
in stakeInput
|
||||
{ stakedAmount = stakedAmount
|
||||
, delegatedTo = ps.newDelegate
|
||||
}
|
||||
|
||||
signer =
|
||||
if ps.signedByOwner
|
||||
then stakeInput.owner
|
||||
else signer2
|
||||
|
||||
st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
|
||||
stakeValue =
|
||||
sortValue $
|
||||
mconcat
|
||||
[ st
|
||||
, Value.assetClassValue
|
||||
(untag stake.gtClassRef)
|
||||
(untag stakeInput.stakedAmount)
|
||||
, minAda
|
||||
]
|
||||
|
||||
builder :: SpendingBuilder
|
||||
builder =
|
||||
mconcat
|
||||
[ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
, signedWith signer
|
||||
, input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeInput
|
||||
. withOutRef stakeRef
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeOutput
|
||||
, withSpendingOutRef stakeRef
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Create a test case that runs the stake validator to test the functionality
|
||||
of setting the delegate.P
|
||||
-}
|
||||
mkTestCase :: String -> Parameters -> Bool -> SpecificationTree
|
||||
mkTestCase name ps valid =
|
||||
testValidator
|
||||
valid
|
||||
name
|
||||
(stakeValidator stake)
|
||||
(mkStakeInputDatum ps)
|
||||
(mkStakeRedeemer ps)
|
||||
(setDelegate ps)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- * Valid Parameters
|
||||
|
||||
overrideExistingDelegateParameters :: Parameters
|
||||
overrideExistingDelegateParameters =
|
||||
Parameters
|
||||
{ existingDelegate = Just $ head pubKeyHashes
|
||||
, newDelegate = Just $ pubKeyHashes !! 2
|
||||
, invalidOutputStake = False
|
||||
, signedByOwner = True
|
||||
}
|
||||
|
||||
clearDelegateParameters :: Parameters
|
||||
clearDelegateParameters =
|
||||
overrideExistingDelegateParameters
|
||||
{ newDelegate = Nothing
|
||||
}
|
||||
|
||||
setDelegateParameters :: Parameters
|
||||
setDelegateParameters =
|
||||
overrideExistingDelegateParameters
|
||||
{ existingDelegate = Nothing
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- * Invalid Parameters
|
||||
|
||||
ownerDoesntSignParameters :: Parameters
|
||||
ownerDoesntSignParameters =
|
||||
overrideExistingDelegateParameters
|
||||
{ signedByOwner = False
|
||||
}
|
||||
|
||||
delegateToOwnerParameters :: Parameters
|
||||
delegateToOwnerParameters =
|
||||
overrideExistingDelegateParameters
|
||||
{ existingDelegate = Nothing
|
||||
, newDelegate = Just stakeOwner
|
||||
}
|
||||
|
||||
invalidOutputStakeDatumParameters :: Parameters
|
||||
invalidOutputStakeDatumParameters =
|
||||
overrideExistingDelegateParameters
|
||||
{ invalidOutputStake = True
|
||||
}
|
||||
|
|
@ -130,7 +130,11 @@ specs =
|
|||
in [legalGroup, illegalGroup]
|
||||
, group
|
||||
"voting"
|
||||
[ Vote.mkTestTree "legal" Vote.validVoteParameters True
|
||||
[ group
|
||||
"legal"
|
||||
[ Vote.mkTestTree "ordinary" Vote.validVoteParameters True
|
||||
, Vote.mkTestTree "delegate" Vote.validVoteAsDelegateParameters True
|
||||
]
|
||||
-- TODO: add negative test cases
|
||||
]
|
||||
, group
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ import Agora.Stake (
|
|||
StakeRedeemer (DepositWithdraw),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Data.Bool (Bool (..))
|
||||
import Data.Maybe (Maybe (..))
|
||||
import Sample.Stake (
|
||||
DepositWithdrawExample (
|
||||
DepositWithdrawExample,
|
||||
|
|
@ -30,6 +32,7 @@ import Sample.Stake qualified as Stake (
|
|||
stakeCreationWrongDatum,
|
||||
stakeDepositWithdraw,
|
||||
)
|
||||
import Sample.Stake.SetDelegate qualified as SetDelegate
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
|
|
@ -67,20 +70,47 @@ specs =
|
|||
[ validatorSucceedsWith
|
||||
"stakeDepositWithdraw deposit"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ StakeDatum 100_000 signer Nothing [])
|
||||
(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 Nothing [])
|
||||
(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 Nothing [])
|
||||
(toDatum $ DepositWithdraw 1_000_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
|
||||
, group
|
||||
"set delegate"
|
||||
[ SetDelegate.mkTestCase
|
||||
"override existing delegate"
|
||||
SetDelegate.overrideExistingDelegateParameters
|
||||
True
|
||||
, SetDelegate.mkTestCase
|
||||
"remove existing delegate"
|
||||
SetDelegate.clearDelegateParameters
|
||||
True
|
||||
, SetDelegate.mkTestCase
|
||||
"set delegate to something"
|
||||
SetDelegate.setDelegateParameters
|
||||
True
|
||||
, SetDelegate.mkTestCase
|
||||
"owner doesn't sign the transaction"
|
||||
SetDelegate.ownerDoesntSignParameters
|
||||
False
|
||||
, SetDelegate.mkTestCase
|
||||
"delegate to the owner"
|
||||
SetDelegate.delegateToOwnerParameters
|
||||
False
|
||||
, SetDelegate.mkTestCase
|
||||
"invalid output stake"
|
||||
SetDelegate.invalidOutputStakeDatumParameters
|
||||
False
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -197,6 +197,7 @@ library agora-specs
|
|||
Sample.Proposal.Vote
|
||||
Sample.Shared
|
||||
Sample.Stake
|
||||
Sample.Stake.SetDelegate
|
||||
Sample.Treasury
|
||||
Spec.AuthorityToken
|
||||
Spec.Effect.GovernorMutation
|
||||
|
|
|
|||
|
|
@ -511,6 +511,7 @@ proposalValidator proposal =
|
|||
PStakeDatum
|
||||
( #stakedAmount .= stakeInF.stakedAmount
|
||||
.& #owner .= stakeInF.owner
|
||||
.& #delegatedTo .= stakeInF.delegatedTo
|
||||
.& #lockedBy .= pdata expectedProposalLocks
|
||||
)
|
||||
|
||||
|
|
@ -588,6 +589,7 @@ proposalValidator proposal =
|
|||
PStakeDatum
|
||||
( #stakedAmount .= stakeInF.stakedAmount
|
||||
.& #owner .= stakeInF.owner
|
||||
.& #delegatedTo .= stakeInF.delegatedTo
|
||||
.& #lockedBy .= pdata stakeOutputLocks
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ import Data.Tagged (Tagged (..))
|
|||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PMaybeData,
|
||||
PPubKeyHash,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
|
|
@ -170,6 +171,11 @@ data StakeRedeemer
|
|||
| -- | The owner can consume stake if nothing is changed about it.
|
||||
-- If the proposal token moves, this is equivalent to the owner consuming it.
|
||||
WitnessStake
|
||||
| -- | The owner can delegate the stake to another user, allowing the
|
||||
-- delegate to vote on prooposals with the stake.
|
||||
DelegateTo PubKeyHash
|
||||
| -- | Revoke the existing delegation.
|
||||
ClearDelegate
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
|
|
@ -179,6 +185,8 @@ PlutusTx.makeIsDataIndexed
|
|||
, ('PermitVote, 2)
|
||||
, ('RetractVotes, 3)
|
||||
, ('WitnessStake, 4)
|
||||
, ('DelegateTo, 5)
|
||||
, ('ClearDelegate, 6)
|
||||
]
|
||||
|
||||
{- | Haskell-level datum for Stake scripts.
|
||||
|
|
@ -194,6 +202,8 @@ data StakeDatum = StakeDatum
|
|||
--
|
||||
-- TODO Support for MultiSig/Scripts is tracked here:
|
||||
-- https://github.com/Liqwid-Labs/agora/issues/45
|
||||
, delegatedTo :: Maybe PubKeyHash
|
||||
-- ^ To whom this stake has been delegated.
|
||||
, lockedBy :: [ProposalLock]
|
||||
-- ^ The current proposals locking this stake. This field must be empty
|
||||
-- for the stake to be usable for deposits and withdrawals.
|
||||
|
|
@ -221,6 +231,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "delegatedTo" ':= PMaybeData PPubKeyHash
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
|
|
@ -277,6 +288,8 @@ data PStakeRedeemer (s :: S)
|
|||
| PPermitVote (Term s (PDataRecord '[]))
|
||||
| PRetractVotes (Term s (PDataRecord '[]))
|
||||
| PWitnessStake (Term s (PDataRecord '[]))
|
||||
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
|
||||
| PClearDelegate (Term s (PDataRecord '[]))
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
|
|
|
|||
|
|
@ -10,12 +10,7 @@ module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
|||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
PStakeDatum (PStakeDatum),
|
||||
PStakeRedeemer (
|
||||
PDepositWithdraw,
|
||||
PDestroy,
|
||||
PPermitVote,
|
||||
PRetractVotes
|
||||
),
|
||||
PStakeRedeemer (..),
|
||||
Stake (gtClassRef, proposalSTClass),
|
||||
StakeRedeemer (WitnessStake),
|
||||
pstakeLocked,
|
||||
|
|
@ -23,6 +18,9 @@ import Agora.Stake (
|
|||
import Agora.Utils (
|
||||
mustBePJust,
|
||||
mustFindDatum',
|
||||
pdjust,
|
||||
pdnothing,
|
||||
pmaybeData,
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Data.Function (on)
|
||||
|
|
@ -44,6 +42,7 @@ import Plutarch.Api.V1 (
|
|||
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf)
|
||||
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent)
|
||||
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
|
||||
import Plutarch.Extra.Maybe (pfromDJust)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
|
|
@ -239,7 +238,7 @@ stakeValidator stake =
|
|||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFieldsC @'["owner", "stakedAmount", "lockedBy"] stakeDatum'
|
||||
stakeDatum <- pletAllC stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
|
||||
|
||||
|
|
@ -251,7 +250,14 @@ stakeValidator stake =
|
|||
resolvedF <- pletFieldsC @'["address", "value", "datumHash"] resolved
|
||||
|
||||
-- Whether the owner signs this transaction or not.
|
||||
ownerSignsTransaction <- pletC $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
|
||||
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
|
||||
|
||||
ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
|
||||
delegateSignsTransaction <-
|
||||
pletC $
|
||||
pmaybeData # pconstant False
|
||||
# plam ((signedBy #) . pdata)
|
||||
# stakeDatum.delegatedTo
|
||||
|
||||
stCurrencySymbol <-
|
||||
pletC $
|
||||
|
|
@ -378,16 +384,42 @@ stakeValidator stake =
|
|||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #delegatedTo .= stakeDatum.delegatedTo
|
||||
.& #lockedBy .= pfield @"lockedBy" # stakeOut
|
||||
)
|
||||
in stakeOut #== templateStakeDatum
|
||||
|
||||
setDelegate <- pletC $
|
||||
plam $ \maybePkh -> unTermCont $ do
|
||||
pguardC
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum =
|
||||
stakeOut
|
||||
#== mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #delegatedTo .= pdata maybePkh
|
||||
.& #lockedBy .= stakeDatum.lockedBy
|
||||
)
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
pure $
|
||||
pmatch stakeRedeemer $ \case
|
||||
PRetractVotes _ -> unTermCont $ do
|
||||
pguardC
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
"Owner or delegate signs this transaction"
|
||||
$ ownerSignsTransaction #|| delegateSignsTransaction
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
|
|
@ -408,8 +440,8 @@ stakeValidator stake =
|
|||
|
||||
PPermitVote _ -> unTermCont $ do
|
||||
pguardC
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
"Owner or delegate signs this transaction"
|
||||
$ ownerSignsTransaction #|| delegateSignsTransaction
|
||||
|
||||
let proposalTokenMinted =
|
||||
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
|
||||
|
|
@ -418,7 +450,6 @@ stakeValidator stake =
|
|||
-- that this is not abused.
|
||||
pguardC "Proposal ST spent or minted" $
|
||||
proposalTokenMoved #|| proposalTokenMinted
|
||||
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum = onlyLocksUpdated
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
|
|
@ -453,6 +484,7 @@ stakeValidator stake =
|
|||
PStakeDatum
|
||||
( #stakedAmount .= pdata newStakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #delegatedTo .= stakeDatum.delegatedTo
|
||||
.& #lockedBy .= stakeDatum.lockedBy
|
||||
)
|
||||
datumCorrect = stakeOut #== expectedDatum
|
||||
|
|
@ -486,6 +518,20 @@ stakeValidator stake =
|
|||
]
|
||||
--
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) -> unTermCont $ do
|
||||
pguardC "Cannot delegate to the owner" $
|
||||
pnot #$ stakeDatum.owner #== pkh
|
||||
|
||||
pure $ setDelegate #$ pdjust # pkh
|
||||
------------------------------------------------------------
|
||||
|
||||
PClearDelegate _ ->
|
||||
setDelegate # pdnothing
|
||||
------------------------------------------------------------
|
||||
|
||||
_ -> popaque (pconstant ())
|
||||
|
||||
pure $
|
||||
|
|
|
|||
|
|
@ -24,6 +24,10 @@ module Agora.Utils (
|
|||
pltAsData,
|
||||
pon,
|
||||
withBuiltinPairAsData,
|
||||
pmaybeData,
|
||||
pmaybe,
|
||||
pdjust,
|
||||
pdnothing,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
|
|
@ -34,7 +38,7 @@ import Plutarch.Api.V1 (
|
|||
PCurrencySymbol,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMaybeData (PDJust),
|
||||
PMaybeData (PDJust, PDNothing),
|
||||
PMintingPolicy,
|
||||
PTokenName (PTokenName),
|
||||
PTuple,
|
||||
|
|
@ -240,3 +244,54 @@ withBuiltinPairAsData f p =
|
|||
let a = pfromData $ pfstBuiltin # p
|
||||
b = pfromData $ psndBuiltin # p
|
||||
in f a b
|
||||
|
||||
{- | Plutarch version of 'Data.Maybe.maybe'. Take a default value and a function
|
||||
@f@. If the given 'PMaybe' value is @'PJust' x@, apply the function @f@ to
|
||||
@x@, otherewise the default value will be retuned.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pmaybe ::
|
||||
forall (a :: PType) (b :: PType) (s :: S).
|
||||
Term s (b :--> (a :--> b) :--> PMaybe a :--> b)
|
||||
pmaybe = phoistAcyclic $
|
||||
plam $ \n f m -> pmatch m $ \case
|
||||
PJust x -> f # x
|
||||
_ -> n
|
||||
|
||||
{- | Special version of 'pmaybe' that works with 'PMaybedata'.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pmaybeData ::
|
||||
forall (a :: PType) (b :: PType) (s :: S).
|
||||
PIsData a =>
|
||||
Term s (b :--> (a :--> b) :--> PMaybeData a :--> b)
|
||||
pmaybeData = phoistAcyclic $
|
||||
plam $ \n f m -> pmatch m $ \case
|
||||
PDJust ((pfield @"_0" #) -> x) -> f # x
|
||||
_ -> n
|
||||
|
||||
{- Construct a 'PDJust' value.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pdjust ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PIsData a) =>
|
||||
Term s (a :--> PMaybeData a)
|
||||
pdjust = phoistAcyclic $
|
||||
plam $ \x ->
|
||||
pcon $
|
||||
PDJust $
|
||||
pdcons @"_0" # pdata x #$ pdnil
|
||||
|
||||
{- Construct a 'PDNothing' value.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pdnothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PIsData a) =>
|
||||
Term s (PMaybeData a)
|
||||
pdnothing = phoistAcyclic $ pcon $ PDNothing pdnil
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue