restructure stake validator
This commit is contained in:
Hongrui Fang
parent
19a241c2d8
commit
759c6a0aa5
1 changed files with 200 additions and 170 deletions
|
|
@ -13,7 +13,6 @@ import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
|
|||
import Agora.Stake (
|
||||
PStakeDatum (PStakeDatum),
|
||||
PStakeRedeemer (..),
|
||||
StakeRedeemer (WitnessStake),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Data.Function (on)
|
||||
|
|
@ -25,7 +24,9 @@ import Plutarch.Api.V1 (
|
|||
)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees (Positive),
|
||||
KeyGuarantees (Sorted),
|
||||
PDatumHash,
|
||||
PMaybeData,
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
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.
|
||||
|
||||
== 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" $
|
||||
spentST #== 1
|
||||
|
||||
ownOutput <- pletC $ phead # ownOutputs
|
||||
|
||||
stakeOut <-
|
||||
pletC $
|
||||
let ownOutputDatum =
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
# (pfield @"datum" # ownOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
ownOutputValue <-
|
||||
pletC $
|
||||
ownOutputValue =
|
||||
pfield @"value" # ownOutput
|
||||
|
||||
ownOutputValueUnchanged <-
|
||||
pletC $
|
||||
ownOutputValueUnchanged =
|
||||
pdata resolvedF.value #== pdata ownOutputValue
|
||||
|
||||
onlyLocksUpdated <-
|
||||
pletC $
|
||||
onlyLocksUpdated =
|
||||
let templateStakeDatum =
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #delegatedTo .= stakeDatum.delegatedTo
|
||||
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut
|
||||
.& #lockedBy .= pfield @"lockedBy"
|
||||
# pto ownOutputDatum
|
||||
)
|
||||
in stakeOut #== templateStakeDatum
|
||||
in ownOutputDatum #== templateStakeDatum
|
||||
|
||||
setDelegate <- pletC $
|
||||
plam $ \maybePkh -> unTermCont $ do
|
||||
ctx =
|
||||
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
|
||||
"Owner signs this transaction"
|
||||
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" $
|
||||
let correctOutputDatum =
|
||||
stakeOut
|
||||
ctx.ownOutputDatum
|
||||
#== mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
|
|
@ -419,18 +463,16 @@ stakeValidator as gtClassRef =
|
|||
.& #delegatedTo .= pdata maybePkh
|
||||
.& #lockedBy .= stakeDatum.lockedBy
|
||||
)
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
valueCorrect = ctx.ownOutputValueUnchanged
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
pure $
|
||||
pmatch stakeRedeemer $ \case
|
||||
PRetractVotes _ -> unTermCont $ do
|
||||
PRetractVotes _ -> withSingleStake $ \ctx -> do
|
||||
pguardC
|
||||
"Owner or delegate signs this transaction"
|
||||
$ ownerSignsTransaction #|| delegateSignsTransaction
|
||||
|
|
@ -440,19 +482,17 @@ stakeValidator as gtClassRef =
|
|||
pguardC "Proposal ST spent" proposalTokenMoved
|
||||
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let valueCorrect = ownOutputValueUnchanged
|
||||
outputDatumCorrect = onlyLocksUpdated
|
||||
let valueCorrect = ctx.ownOutputValueUnchanged
|
||||
outputDatumCorrect = ctx.onlyLocksUpdated
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" outputDatumCorrect
|
||||
]
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
------------------------------------------------------------------
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
PPermitVote _ -> unTermCont $ do
|
||||
PPermitVote _ -> withSingleStake $ \ctx -> do
|
||||
pguardC
|
||||
"Owner or delegate signs this transaction"
|
||||
$ ownerSignsTransaction #|| delegateSignsTransaction
|
||||
|
|
@ -465,19 +505,25 @@ stakeValidator as gtClassRef =
|
|||
pguardC "Proposal ST spent or minted" $
|
||||
proposalTokenMoved #|| proposalTokenMinted
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum = onlyLocksUpdated
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
let correctOutputDatum = ctx.onlyLocksUpdated
|
||||
valueCorrect = ctx.ownOutputValueUnchanged
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, 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" $
|
||||
pnot #$ stakeIsLocked
|
||||
pguardC
|
||||
|
|
@ -501,7 +547,7 @@ stakeValidator as gtClassRef =
|
|||
.& #delegatedTo .= stakeDatum.delegatedTo
|
||||
.& #lockedBy .= stakeDatum.lockedBy
|
||||
)
|
||||
datumCorrect = stakeOut #== expectedDatum
|
||||
datumCorrect = ctx.ownOutputDatum #== expectedDatum
|
||||
|
||||
let valueDelta :: Term _ (PValue _ 'Positive)
|
||||
valueDelta = pdiscreteValue' gtClassRef # delta
|
||||
|
|
@ -513,14 +559,14 @@ stakeValidator as gtClassRef =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", ""))
|
||||
# ownOutputValue
|
||||
# ctx.ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqByClass' (untag gtClassRef)
|
||||
# ownOutputValue
|
||||
# ctx.ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# ownOutputValue
|
||||
# ctx.ownOutputValue
|
||||
# expectedValue
|
||||
]
|
||||
--
|
||||
|
|
@ -530,26 +576,10 @@ stakeValidator as gtClassRef =
|
|||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" datumCorrect
|
||||
]
|
||||
--
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
------------------------------------------------------------
|
||||
------------------------------------------------------------------
|
||||
|
||||
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) -> unTermCont $ do
|
||||
pguardC "Cannot delegate to the owner" $
|
||||
pnot #$ stakeDatum.owner #== pkh
|
||||
PWitnessStake _ -> witnessStake
|
||||
------------------------------------------------------------------
|
||||
|
||||
pure $ setDelegate #$ pdjust # pdata pkh
|
||||
------------------------------------------------------------
|
||||
|
||||
PClearDelegate _ ->
|
||||
setDelegate # pdnothing
|
||||
------------------------------------------------------------
|
||||
|
||||
_ -> popaque (pconstant ())
|
||||
|
||||
pure $
|
||||
pif
|
||||
(pdata stakeRedeemer #== pconstantData WitnessStake)
|
||||
witnessStake
|
||||
onlyAcceptOneStake
|
||||
_ -> ptraceError "unreachable"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue