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

restructure stake validator

Browse source
This commit is contained in:
Hongrui Fang 2022-08-30 21:09:37 +08:00
parent 19a241c2d8
commit 759c6a0aa5
1 changed files with 200 additions and 170 deletions
Download patch file Download diff file Expand all files Collapse all files

138
agora/Agora/Stake/Scripts.hs
View file

@ -13,7 +13,6 @@ import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
import Agora.Stake ( import Agora.Stake (
PStakeDatum (PStakeDatum), PStakeDatum (PStakeDatum),
PStakeRedeemer (..), PStakeRedeemer (..),
StakeRedeemer (WitnessStake),
pstakeLocked, pstakeLocked,
) )
import Data.Function (on) import Data.Function (on)
@ -25,7 +24,9 @@ import Plutarch.Api.V1 (
) )
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
AmountGuarantees (Positive), AmountGuarantees (Positive),
KeyGuarantees (Sorted),
PDatumHash, PDatumHash,
PMaybeData,
PMintingPolicy, PMintingPolicy,
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
PTxInfo, PTxInfo,
@ -178,6 +179,22 @@ stakePolicy gtClassRef =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data POnlyOneStakeContext (s :: S) = POnlyOneStakeContext
{ ownOutputDatum :: Term s PStakeDatum
, ownOutputValue :: Term s (PValue 'Sorted 'Positive)
, ownOutputValueUnchanged :: Term s PBool
, onlyLocksUpdated :: Term s PBool
}
deriving stock
( Generic
)
deriving anyclass
( PlutusType
)
instance DerivePlutusType POnlyOneStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | Validator intended for Stake UTXOs to be locked by. {- | Validator intended for Stake UTXOs to be locked by.
== What this Validator does: == What this Validator does:
@ -370,48 +387,75 @@ stakeValidator as gtClassRef =
---------------------------------------------------------------------- ----------------------------------------------------------------------
let onlyAcceptOneStake = unTermCont $ do withSingleStake' ::
Term
s
( (POnlyOneStakeContext :--> PUnit)
:--> POpaque
) <-
pletC $
plam $ \validationLogic -> unTermCont $ do
pguardC "ST at inputs must be 1" $ pguardC "ST at inputs must be 1" $
spentST #== 1 spentST #== 1
ownOutput <- pletC $ phead # ownOutputs ownOutput <- pletC $ phead # ownOutputs
stakeOut <- let ownOutputDatum =
pletC $
pfromData $ pfromData $
pfromOutputDatum @(PAsData PStakeDatum) pfromOutputDatum @(PAsData PStakeDatum)
# (pfield @"datum" # ownOutput) # (pfield @"datum" # ownOutput)
# txInfoF.datums # txInfoF.datums
ownOutputValue <- ownOutputValue =
pletC $
pfield @"value" # ownOutput pfield @"value" # ownOutput
ownOutputValueUnchanged <- ownOutputValueUnchanged =
pletC $
pdata resolvedF.value #== pdata ownOutputValue pdata resolvedF.value #== pdata ownOutputValue
onlyLocksUpdated <- onlyLocksUpdated =
pletC $
let templateStakeDatum = let templateStakeDatum =
mkRecordConstr mkRecordConstr
PStakeDatum PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount ( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner .& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo .& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut .& #lockedBy .= pfield @"lockedBy"
# pto ownOutputDatum
) )
in stakeOut #== templateStakeDatum in ownOutputDatum #== templateStakeDatum
setDelegate <- pletC $ ctx =
plam $ \maybePkh -> unTermCont $ do pcon $
POnlyOneStakeContext
ownOutputDatum
ownOutputValue
ownOutputValueUnchanged
onlyLocksUpdated
pure $ popaque $ validationLogic # ctx
let withSingleStake val = withSingleStake' #$ plam $ \ctx ->
unTermCont $ do
ctxF <- pmatchC ctx
val ctxF
pure $ pconstant ()
setDelegate :: Term s (PMaybeData (PAsData PCredential) :--> POpaque) <-
pletC $
plam $ \maybePkh -> withSingleStake $ \ctx -> do
pguardC pguardC
"Owner signs this transaction" "Owner signs this transaction"
ownerSignsTransaction ownerSignsTransaction
pguardC "Cannot delegate to the owner" $
pmaybeData
# pcon PTrue
# plam (\pkh -> pnot #$ stakeDatum.owner #== pkh)
# maybePkh
pguardC "A UTXO must exist with the correct output" $ pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = let correctOutputDatum =
stakeOut ctx.ownOutputDatum
#== mkRecordConstr #== mkRecordConstr
PStakeDatum PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount ( #stakedAmount .= stakeDatum.stakedAmount
@ -419,18 +463,16 @@ stakeValidator as gtClassRef =
.& #delegatedTo .= pdata maybePkh .& #delegatedTo .= pdata maybePkh
.& #lockedBy .= stakeDatum.lockedBy .& #lockedBy .= stakeDatum.lockedBy
) )
valueCorrect = ownOutputValueUnchanged valueCorrect = ctx.ownOutputValueUnchanged
in foldl1 in foldl1
(#&&) (#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum , ptraceIfFalse "datumCorrect" correctOutputDatum
] ]
pure $ popaque (pconstant ())
pure $ pure $
pmatch stakeRedeemer $ \case pmatch stakeRedeemer $ \case
PRetractVotes _ -> unTermCont $ do PRetractVotes _ -> withSingleStake $ \ctx -> do
pguardC pguardC
"Owner or delegate signs this transaction" "Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction $ ownerSignsTransaction #|| delegateSignsTransaction
@ -440,19 +482,17 @@ stakeValidator as gtClassRef =
pguardC "Proposal ST spent" proposalTokenMoved pguardC "Proposal ST spent" proposalTokenMoved
pguardC "A UTXO must exist with the correct output" $ pguardC "A UTXO must exist with the correct output" $
let valueCorrect = ownOutputValueUnchanged let valueCorrect = ctx.ownOutputValueUnchanged
outputDatumCorrect = onlyLocksUpdated outputDatumCorrect = ctx.onlyLocksUpdated
in foldl1 in foldl1
(#&&) (#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect , ptraceIfFalse "datumCorrect" outputDatumCorrect
] ]
pure $ popaque (pconstant ()) ------------------------------------------------------------------
------------------------------------------------------------ PPermitVote _ -> withSingleStake $ \ctx -> do
PPermitVote _ -> unTermCont $ do
pguardC pguardC
"Owner or delegate signs this transaction" "Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction $ ownerSignsTransaction #|| delegateSignsTransaction
@ -465,19 +505,25 @@ stakeValidator as gtClassRef =
pguardC "Proposal ST spent or minted" $ pguardC "Proposal ST spent or minted" $
proposalTokenMoved #|| proposalTokenMinted proposalTokenMoved #|| proposalTokenMinted
pguardC "A UTXO must exist with the correct output" $ pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = onlyLocksUpdated let correctOutputDatum = ctx.onlyLocksUpdated
valueCorrect = ownOutputValueUnchanged valueCorrect = ctx.ownOutputValueUnchanged
in foldl1 in foldl1
(#&&) (#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum , ptraceIfFalse "datumCorrect" correctOutputDatum
] ]
pure $ popaque (pconstant ()) ------------------------------------------------------------------
------------------------------------------------------------ PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) ->
setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------------
PDepositWithdraw r -> unTermCont $ do PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------------
PDepositWithdraw r -> withSingleStake $ \ctx -> do
pguardC "Stake unlocked" $ pguardC "Stake unlocked" $
pnot #$ stakeIsLocked pnot #$ stakeIsLocked
pguardC pguardC
@ -501,7 +547,7 @@ stakeValidator as gtClassRef =
.& #delegatedTo .= stakeDatum.delegatedTo .& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= stakeDatum.lockedBy .& #lockedBy .= stakeDatum.lockedBy
) )
datumCorrect = stakeOut #== expectedDatum datumCorrect = ctx.ownOutputDatum #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive) let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' gtClassRef # delta valueDelta = pdiscreteValue' gtClassRef # delta
@ -513,14 +559,14 @@ stakeValidator as gtClassRef =
foldr1 foldr1
(#&&) (#&&)
[ pgeqByClass' (AssetClass ("", "")) [ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue # ctx.ownOutputValue
# expectedValue # expectedValue
, pgeqByClass' (untag gtClassRef) , pgeqByClass' (untag gtClassRef)
# ownOutputValue # ctx.ownOutputValue
# expectedValue # expectedValue
, pgeqBySymbol , pgeqBySymbol
# stCurrencySymbol # stCurrencySymbol
# ownOutputValue # ctx.ownOutputValue
# expectedValue # expectedValue
] ]
-- --
@ -530,26 +576,10 @@ stakeValidator as gtClassRef =
[ ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect , ptraceIfFalse "datumCorrect" datumCorrect
] ]
--
pure $ popaque (pconstant ())
------------------------------------------------------------ ------------------------------------------------------------------
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) -> unTermCont $ do PWitnessStake _ -> witnessStake
pguardC "Cannot delegate to the owner" $ ------------------------------------------------------------------
pnot #$ stakeDatum.owner #== pkh
pure $ setDelegate #$ pdjust # pdata pkh _ -> ptraceError "unreachable"
------------------------------------------------------------
PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------
_ -> popaque (pconstant ())
pure $
pif
(pdata stakeRedeemer #== pconstantData WitnessStake)
witnessStake
onlyAcceptOneStake