Merge pull request #92 from Liqwid-Labs/connor/#87
This commit is contained in:
方泓睿
GitHub
commit
50bf78aae8
4 changed files with 261 additions and 338 deletions
|
|
@ -37,7 +37,6 @@ import GHC.Generics qualified as GHC
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (
|
||||
allOutputs,
|
||||
plookup,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
|
|
@ -134,7 +133,7 @@ authorityTokenPolicy params =
|
|||
pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
|
||||
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
|
||||
PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo
|
||||
txInfo <- tcont $ pletFields @'["inputs", "mint"] txInfo'
|
||||
txInfo <- tcont $ pletFields @'["inputs", "mint", "outputs"] txInfo'
|
||||
let inputs = txInfo.inputs
|
||||
mintedValue = pfromData txInfo.mint
|
||||
AssetClass (govCs, govTn) = params.authority
|
||||
|
|
@ -151,10 +150,12 @@ authorityTokenPolicy params =
|
|||
( unTermCont $ do
|
||||
tcassert "Parent token did not move in minting GATs" govTokenSpent
|
||||
tcassert "All outputs only emit valid GATs" $
|
||||
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# ownSymbol
|
||||
# txOut
|
||||
pall
|
||||
# plam
|
||||
( (authorityTokensValidIn # ownSymbol #)
|
||||
. pfromData
|
||||
)
|
||||
# txInfo.outputs
|
||||
pure $ popaque $ pconstant ()
|
||||
)
|
||||
(popaque $ pconstant ())
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ import Agora.Proposal.Time (currentProposalTime, isVotingPeriod)
|
|||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy)
|
||||
import Agora.Utils (
|
||||
anyOutput,
|
||||
findTxOutByTxOutRef,
|
||||
getMintingPolicySymbol,
|
||||
mustBePJust,
|
||||
|
|
@ -188,25 +187,23 @@ proposalValidator proposal =
|
|||
|
||||
-- Filter out own output with own address and PST.
|
||||
-- Delay the evaluation cause in some cases there won't be any continuing output.
|
||||
ownOutputD <-
|
||||
ownOutput <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustBePJust # "Own output should be present" #$ pfind
|
||||
# plam
|
||||
( \input -> unTermCont $ do
|
||||
inputF <- tcont $ pletFields @'["address", "value"] input
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
mustBePJust # "Own output should be present" #$ pfind
|
||||
# plam
|
||||
( \input -> unTermCont $ do
|
||||
inputF <- tcont $ pletFields @'["address", "value"] input
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
proposalOutD <-
|
||||
proposalOut <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustFindDatum' @PProposalDatum
|
||||
# (pfield @"datumHash" # pforce ownOutputD)
|
||||
# txInfoF.datums
|
||||
mustFindDatum' @PProposalDatum
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
pure $
|
||||
pmatch proposalRedeemer $ \case
|
||||
|
|
@ -274,7 +271,7 @@ proposalValidator proposal =
|
|||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
|
||||
tcassert "Output proposal should be valid" $ pforce proposalOutD #== expectedProposalOut
|
||||
tcassert "Output proposal should be valid" $ proposalOut #== expectedProposalOut
|
||||
|
||||
-- We validate the output stake datum here as well: We need the vote option
|
||||
-- to create a valid 'ProposalLock', however the vote option is encoded
|
||||
|
|
@ -346,34 +343,22 @@ proposalValidator proposal =
|
|||
)
|
||||
# newSigs
|
||||
|
||||
let updatedSigs = pconcat # newSigs # proposalF.cosigners
|
||||
expectedDatum =
|
||||
mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
|
||||
tcassert "Signatures are correctly added to cosignature list" $
|
||||
anyOutput @PProposalDatum # ctx.txInfo
|
||||
#$ plam
|
||||
$ \newValue address newProposalDatum ->
|
||||
let updatedSigs = pconcat # newSigs # proposalF.cosigners
|
||||
correctDatum =
|
||||
pdata newProposalDatum
|
||||
#== pdata
|
||||
( mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
)
|
||||
in foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Datum must be correct" correctDatum
|
||||
, ptraceIfFalse "Value should be correct" $
|
||||
pdata txOutF.value #== pdata newValue
|
||||
, ptraceIfFalse "Must be sent to Proposal's address" $
|
||||
ownAddress #== pdata address
|
||||
]
|
||||
proposalOut #== expectedDatum
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,14 +11,12 @@ import Agora.Record (mkRecordConstr, (.&), (.=))
|
|||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
mustBePJust,
|
||||
mustFindDatum',
|
||||
paddValue,
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
|
|
@ -39,12 +37,13 @@ import Plutarch.Api.V1 (
|
|||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf, pvalueOf)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Numeric
|
||||
import Plutarch.SafeMoney (
|
||||
Tagged (..),
|
||||
pdiscreteValue',
|
||||
pvalueDiscrete',
|
||||
untag,
|
||||
)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
|
@ -77,7 +76,7 @@ stakePolicy gtClassRef =
|
|||
txInfo <- tclet $ ctx.txInfo
|
||||
let _a :: Term _ PTxInfo
|
||||
_a = txInfo
|
||||
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories", "datums"] txInfo
|
||||
|
||||
PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
|
||||
ownSymbol <- tclet $ pfield @"_0" # ownSymbol'
|
||||
|
|
@ -92,12 +91,19 @@ stakePolicy gtClassRef =
|
|||
mintedST #== -1
|
||||
|
||||
tcassert "An unlocked input existed containing an ST" $
|
||||
anyInput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' ->
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
unlocked = pnot # (stakeLocked # stakeDatum')
|
||||
in hasST #&& unlocked
|
||||
pany
|
||||
# plam
|
||||
( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
|
||||
txOutF <- tcont $ pletFields @'["value", "datumHash"] txOut
|
||||
pure $
|
||||
pif
|
||||
(psymbolValueOf # ownSymbol # txOutF.value #== 1)
|
||||
( let datum = mustFindDatum' @PStakeDatum # txOutF.datumHash # txInfoF.datums
|
||||
in pnot # (stakeLocked # datum)
|
||||
)
|
||||
(pconstant False)
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
|
|
@ -109,52 +115,44 @@ stakePolicy gtClassRef =
|
|||
mintedST #== 1
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address stakeDatum' ->
|
||||
let cred = pfield @"credential" # address
|
||||
in pmatch cred $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential validatorHash -> unTermCont $ do
|
||||
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
unTermCont $ do
|
||||
let scriptOutputWithStakeST =
|
||||
mustBePJust
|
||||
# "Output to script not found"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \output -> unTermCont $ do
|
||||
outputF <- tcont $ pletFields @'["value", "address"] output
|
||||
pure $
|
||||
pmatch (pfromData $ pfield @"credential" # outputF.address) $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential ((pfield @"_0" #) -> validatorHash) ->
|
||||
let tn :: Term _ PTokenName
|
||||
tn = pvalidatorHashToTokenName validatorHash
|
||||
in pvalueOf # outputF.value # ownSymbol # tn #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
tn :: Term _ PTokenName <- tclet (pvalidatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
|
||||
outputF <-
|
||||
tcont $
|
||||
pletFields @'["value", "address", "datumHash"] scriptOutputWithStakeST
|
||||
datumF <-
|
||||
tcont $
|
||||
pletFields @'["owner", "stakedAmount"] $
|
||||
mustFindDatum' @PStakeDatum # outputF.datumHash # txInfoF.datums
|
||||
|
||||
let stValue =
|
||||
psingletonValue
|
||||
# ownSymbol
|
||||
-- This coerce is safe because the structure
|
||||
-- of PValidatorHash is the same as PTokenName.
|
||||
# tn
|
||||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
# txInfoF.signatories
|
||||
# stakeDatum.owner
|
||||
let hasExpectedStake =
|
||||
ptraceIfFalse "Stake ouput has expected amount of stake token" $
|
||||
pvalueDiscrete' gtClassRef # outputF.value #== datumF.stakedAmount
|
||||
let ownerSignsTransaction =
|
||||
ptraceIfFalse "Stake Owner should sign the transaction" $
|
||||
ptxSignedBy
|
||||
# txInfoF.signatories
|
||||
# datumF.owner
|
||||
|
||||
-- TODO: 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.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
# ownSymbol
|
||||
# tn
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
pure $ hasExpectedStake #&& ownerSignsTransaction
|
||||
|
||||
pure $ ownerSignsTransaction #&& valueCorrect
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
pure $ pif (0 #< mintedST) minting burning
|
||||
|
|
@ -216,7 +214,7 @@ stakeValidator stake =
|
|||
plam $ \datum redeemer ctx' -> unTermCont $ do
|
||||
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- tclet $ pfromData ctx.txInfo
|
||||
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories", "datums"] txInfo
|
||||
|
||||
(pfromData -> stakeRedeemer, _) <- tctryFrom redeemer
|
||||
|
||||
|
|
@ -261,168 +259,185 @@ stakeValidator stake =
|
|||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PRetractVotes _ -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' ->
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
valueCorrect = pdata continuingValue #== pdata value
|
||||
in pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote l -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
-- Update the stake datum, but only the 'lockedBy' field.
|
||||
|
||||
let -- We actually don't know whether the given lock is valid or not.
|
||||
-- This is checked in the proposal validator.
|
||||
newLock = pfield @"lock" # l
|
||||
-- Prepend the new lock to the existing locks.
|
||||
expectedLocks = pcons # newLock # stakeDatum.lockedBy
|
||||
|
||||
expectedDatum <-
|
||||
-- Handle redeemers that require own stake output.
|
||||
_ -> unTermCont $ do
|
||||
-- Filter out own output with own address and PST.
|
||||
ownOutput <-
|
||||
tclet $
|
||||
pdata $
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #lockedBy .= pdata expectedLocks
|
||||
mustBePJust # "Own output should be present" #$ pfind
|
||||
# plam
|
||||
( \input -> unTermCont $ do
|
||||
inputF <- tcont $ pletFields @'["address", "value"] input
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
-- FIXME: no need to pass the whole txInfo to 'anyOutput'.
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' ->
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
correctOutputDatum = pdata newStakeDatum' #== expectedDatum
|
||||
valueCorrect = pdata continuingValue #== pdata value
|
||||
in pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
stakeOut <-
|
||||
tclet $
|
||||
mustFindDatum' @PStakeDatum
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PWitnessStake _ -> unTermCont $ do
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
ownOutputValue <-
|
||||
tclet $
|
||||
pfield @"value" # ownOutput
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
propAssetClass = passetClass # pconstant propCs # pconstant propTn
|
||||
proposalTokenMoved =
|
||||
ptokenSpent
|
||||
# propAssetClass
|
||||
# txInfoF.inputs
|
||||
ownOutputValueUnchanged <-
|
||||
tclet $
|
||||
pdata continuingValue #== pdata ownOutputValue
|
||||
|
||||
-- In order for cosignature to be witnessed, it must be possible for a
|
||||
-- proposal to allow this transaction to happen. This puts trust into the Proposal.
|
||||
-- The Proposal must necessarily check that this is not abused.
|
||||
tcassert
|
||||
"Owner signs this transaction OR proposal token is spent"
|
||||
(ownerSignsTransaction #|| proposalTokenMoved)
|
||||
stakeOutUnchanged <-
|
||||
tclet $
|
||||
pdata stakeOut #== pdata stakeDatum'
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' ->
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
valueCorrect = pdata continuingValue #== pdata value
|
||||
in pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
pure $ popaque (pconstant ())
|
||||
PDepositWithdraw r -> unTermCont $ do
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
tcassert "Stake unlocked" $
|
||||
pnot #$ stakeIsLocked
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> unTermCont $ do
|
||||
newStakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
delta <- tclet $ pfield @"delta" # r
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum =
|
||||
foldr1
|
||||
pure $
|
||||
pmatch stakeRedeemer $ \case
|
||||
PRetractVotes _ -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
unTermCont $ do
|
||||
let valueCorrect = ownOutputValueUnchanged
|
||||
|
||||
-- TODO: check output datum is expected.
|
||||
|
||||
pure $
|
||||
foldl1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
|
||||
|
||||
-- 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.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# value
|
||||
# expectedValue
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
|
||||
pure $
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "isScriptAddress" isScriptAddress
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
, ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote l -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
-- Update the stake datum, but only the 'lockedBy' field.
|
||||
|
||||
let -- We actually don't know whether the given lock is valid or not.
|
||||
-- This is checked in the proposal validator.
|
||||
newLock = pfield @"lock" # l
|
||||
-- Prepend the new lock to the existing locks.
|
||||
expectedLocks = pcons # newLock # stakeDatum.lockedBy
|
||||
|
||||
expectedDatum <-
|
||||
tclet $
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #lockedBy .= pdata expectedLocks
|
||||
)
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum = stakeOut #== expectedDatum
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PWitnessStake _ -> unTermCont $ do
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
propAssetClass = passetClass # pconstant propCs # pconstant propTn
|
||||
proposalTokenMoved =
|
||||
ptokenSpent
|
||||
# propAssetClass
|
||||
# txInfoF.inputs
|
||||
|
||||
-- In order for cosignature to be witnessed, it must be possible for a
|
||||
-- proposal to allow this transaction to happen. This puts trust into the Proposal.
|
||||
-- The Proposal must necessarily check that this is not abused.
|
||||
tcassert
|
||||
"Owner signs this transaction OR proposal token is spent"
|
||||
(ownerSignsTransaction #|| proposalTokenMoved)
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum = stakeOutUnchanged
|
||||
valueCorrect = ownOutputValueUnchanged
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
]
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PDepositWithdraw r -> unTermCont $ do
|
||||
tcassert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
tcassert "Stake unlocked" $
|
||||
pnot #$ stakeIsLocked
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
unTermCont $ do
|
||||
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
|
||||
delta = pfromData $ pfield @"delta" # r
|
||||
|
||||
newStakedAmount <- tclet $ oldStakedAmount + delta
|
||||
|
||||
tcassert "New staked amount shoudl be greater than or equal to 0" $
|
||||
zero #<= newStakedAmount
|
||||
|
||||
let expectedDatum =
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= pdata newStakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #lockedBy .= stakeDatum.lockedBy
|
||||
)
|
||||
datumCorrect = stakeOut #== expectedDatum
|
||||
|
||||
let expectedValue =
|
||||
paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
|
||||
|
||||
valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", ""))
|
||||
# ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# ownOutputValue
|
||||
# expectedValue
|
||||
]
|
||||
--
|
||||
pure $
|
||||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" datumCorrect
|
||||
]
|
||||
--
|
||||
pure $ popaque (pconstant ())
|
||||
_ -> popaque (pconstant ())
|
||||
|
|
|
|||
|
|
@ -44,9 +44,6 @@ module Agora.Utils (
|
|||
pmapMaybe,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
allOutputs,
|
||||
anyInput,
|
||||
findTxOutByTxOutRef,
|
||||
scriptHashFromAddress,
|
||||
findOutputsToAddress,
|
||||
|
|
@ -91,7 +88,6 @@ import Plutarch.Api.V1 (
|
|||
PTokenName (PTokenName),
|
||||
PTuple,
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxInfo,
|
||||
PTxOut (PTxOut),
|
||||
PTxOutRef,
|
||||
PValidatorHash,
|
||||
|
|
@ -560,80 +556,6 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
|
|||
All of these functions are quite inefficient.
|
||||
-}
|
||||
|
||||
-- | Check if any output matches the predicate.
|
||||
anyOutput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyOutput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> unTermCont $ do
|
||||
txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
|
||||
pure $
|
||||
pany
|
||||
# plam
|
||||
( \txOut'' -> unTermCont $ do
|
||||
PTxOut txOut' <- tcmatch (pfromData txOut'')
|
||||
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- tcmatch txOut.datumHash
|
||||
pure $
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# pfromData txInfo.outputs
|
||||
|
||||
-- | Check if all outputs match the predicate.
|
||||
allOutputs ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
allOutputs = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> unTermCont $ do
|
||||
txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
|
||||
pure $
|
||||
pall
|
||||
# plam
|
||||
( \txOut'' -> unTermCont $ do
|
||||
PTxOut txOut' <- tcmatch (pfromData txOut'')
|
||||
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- tcmatch txOut.datumHash
|
||||
pure $
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# pfromData txInfo.outputs
|
||||
|
||||
-- | Check if any (resolved) input matches the predicate.
|
||||
anyInput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyInput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> unTermCont $ do
|
||||
txInfo <- tcont $ pletFields @'["inputs", "datums"] txInfo'
|
||||
pure $
|
||||
pany
|
||||
# plam
|
||||
( \txInInfo'' -> unTermCont $ do
|
||||
PTxInInfo txInInfo' <- tcmatch (pfromData txInInfo'')
|
||||
let txOut'' = pfield @"resolved" # txInInfo'
|
||||
PTxOut txOut' <- tcmatch (pfromData txOut'')
|
||||
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- tcmatch txOut.datumHash
|
||||
pure $
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# pfromData txInfo.inputs
|
||||
|
||||
-- | Create a value with a single asset class.
|
||||
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
|
||||
psingletonValue = phoistAcyclic $
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue