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

Merge pull request #92 from Liqwid-Labs/connor/#87

Browse source
This commit is contained in:
方泓睿 2022-05-25 18:45:22 +08:00 • committed by GitHub
commit f2f355b47c
4 changed files with 261 additions and 338 deletions
Download patch file Download diff file Expand all files Collapse all files

13
agora/Agora/AuthorityToken.hs
View file

@ -37,7 +37,6 @@ import GHC.Generics qualified as GHC
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Agora.Utils ( import Agora.Utils (
allOutputs,
plookup, plookup,
psymbolValueOf, psymbolValueOf,
ptokenSpent, ptokenSpent,
@ -134,7 +133,7 @@ authorityTokenPolicy params =
pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo
txInfo <- tcont $ pletFields @'["inputs", "mint"] txInfo' txInfo <- tcont $ pletFields @'["inputs", "mint", "outputs"] txInfo'
let inputs = txInfo.inputs let inputs = txInfo.inputs
mintedValue = pfromData txInfo.mint mintedValue = pfromData txInfo.mint
AssetClass (govCs, govTn) = params.authority AssetClass (govCs, govTn) = params.authority
@ -151,10 +150,12 @@ authorityTokenPolicy params =
( unTermCont $ do ( unTermCont $ do
tcassert "Parent token did not move in minting GATs" govTokenSpent tcassert "Parent token did not move in minting GATs" govTokenSpent
tcassert "All outputs only emit valid GATs" $ tcassert "All outputs only emit valid GATs" $
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> pall
authorityTokensValidIn # plam
# ownSymbol ( (authorityTokensValidIn # ownSymbol #)
# txOut . pfromData
)
# txInfo.outputs
pure $ popaque $ pconstant () pure $ popaque $ pconstant ()
) )
(popaque $ pconstant ()) (popaque $ pconstant ())

75
agora/Agora/Proposal/Scripts.hs
View file

@ -21,7 +21,6 @@ import Agora.Proposal.Time (currentProposalTime, isVotingPeriod)
import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy) import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy)
import Agora.Utils ( import Agora.Utils (
anyOutput,
findTxOutByTxOutRef, findTxOutByTxOutRef,
getMintingPolicySymbol, getMintingPolicySymbol,
mustBePJust, mustBePJust,
@ -188,25 +187,23 @@ proposalValidator proposal =
-- Filter out own output with own address and PST. -- Filter out own output with own address and PST.
-- Delay the evaluation cause in some cases there won't be any continuing output. -- Delay the evaluation cause in some cases there won't be any continuing output.
ownOutputD <- ownOutput <-
tclet $ tclet $
pdelay $ mustBePJust # "Own output should be present" #$ pfind
mustBePJust # "Own output should be present" #$ pfind # plam
# plam ( \input -> unTermCont $ do
( \input -> unTermCont $ do inputF <- tcont $ pletFields @'["address", "value"] input
inputF <- tcont $ pletFields @'["address", "value"] input pure $
pure $ inputF.address #== ownAddress
inputF.address #== ownAddress #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 )
) # pfromData txInfoF.outputs
# pfromData txInfoF.outputs
proposalOutD <- proposalOut <-
tclet $ tclet $
pdelay $ mustFindDatum' @PProposalDatum
mustFindDatum' @PProposalDatum # (pfield @"datumHash" # ownOutput)
# (pfield @"datumHash" # pforce ownOutputD) # txInfoF.datums
# txInfoF.datums
pure $ pure $
pmatch proposalRedeemer $ \case pmatch proposalRedeemer $ \case
@ -274,7 +271,7 @@ proposalValidator proposal =
.& #startingTime .= proposalF.startingTime .& #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 -- 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 -- to create a valid 'ProposalLock', however the vote option is encoded
@ -346,34 +343,22 @@ proposalValidator proposal =
) )
# newSigs # 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" $ tcassert "Signatures are correctly added to cosignature list" $
anyOutput @PProposalDatum # ctx.txInfo proposalOut #== expectedDatum
#$ 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
]
pure $ popaque (pconstant ()) pure $ popaque (pconstant ())
-------------------------------------------------------------------------- --------------------------------------------------------------------------

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

@ -11,14 +11,12 @@ import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Stake import Agora.Stake
import Agora.Utils ( import Agora.Utils (
anyInput, mustBePJust,
anyOutput, mustFindDatum',
paddValue, paddValue,
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
pgeqByClass,
pgeqByClass', pgeqByClass',
pgeqBySymbol, pgeqBySymbol,
psingletonValue,
psymbolValueOf, psymbolValueOf,
ptokenSpent, ptokenSpent,
ptxSignedBy, ptxSignedBy,
@ -39,12 +37,13 @@ import Plutarch.Api.V1 (
mintingPolicySymbol, mintingPolicySymbol,
mkMintingPolicy, mkMintingPolicy,
) )
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf, pvalueOf)
import Plutarch.Internal (punsafeCoerce) import Plutarch.Internal (punsafeCoerce)
import Plutarch.Numeric import Plutarch.Numeric
import Plutarch.SafeMoney ( import Plutarch.SafeMoney (
Tagged (..), Tagged (..),
pdiscreteValue', pdiscreteValue',
pvalueDiscrete',
untag, untag,
) )
import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
@ -77,7 +76,7 @@ stakePolicy gtClassRef =
txInfo <- tclet $ ctx.txInfo txInfo <- tclet $ ctx.txInfo
let _a :: Term _ PTxInfo let _a :: Term _ PTxInfo
_a = txInfo _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 PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
ownSymbol <- tclet $ pfield @"_0" # ownSymbol' ownSymbol <- tclet $ pfield @"_0" # ownSymbol'
@ -92,12 +91,19 @@ stakePolicy gtClassRef =
mintedST #== -1 mintedST #== -1
tcassert "An unlocked input existed containing an ST" $ tcassert "An unlocked input existed containing an ST" $
anyInput @PStakeDatum # txInfo pany
#$ plam # plam
$ \value _ stakeDatum' -> ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
let hasST = psymbolValueOf # ownSymbol # value #== 1 txOutF <- tcont $ pletFields @'["value", "datumHash"] txOut
unlocked = pnot # (stakeLocked # stakeDatum') pure $
in hasST #&& unlocked 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 ()) pure $ popaque (pconstant ())
@ -109,52 +115,44 @@ stakePolicy gtClassRef =
mintedST #== 1 mintedST #== 1
tcassert "A UTXO must exist with the correct output" $ tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo unTermCont $ do
#$ plam let scriptOutputWithStakeST =
$ \value address stakeDatum' -> mustBePJust
let cred = pfield @"credential" # address # "Output to script not found"
in pmatch cred $ \case #$ pfind
-- Should pay to a script address # plam
PPubKeyCredential _ -> pcon PFalse ( \output -> unTermCont $ do
PScriptCredential validatorHash -> unTermCont $ do outputF <- tcont $ pletFields @'["value", "address"] output
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum' 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 = let hasExpectedStake =
psingletonValue ptraceIfFalse "Stake ouput has expected amount of stake token" $
# ownSymbol pvalueDiscrete' gtClassRef # outputF.value #== datumF.stakedAmount
-- This coerce is safe because the structure let ownerSignsTransaction =
-- of PValidatorHash is the same as PTokenName. ptraceIfFalse "Stake Owner should sign the transaction" $
# tn ptxSignedBy
# 1 # txInfoF.signatories
let expectedValue = # datumF.owner
paddValue
# (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
# stValue
let ownerSignsTransaction =
ptxSignedBy
# txInfoF.signatories
# stakeDatum.owner
-- TODO: This is quite inefficient now, as it does two lookups pure $ hasExpectedStake #&& ownerSignsTransaction
-- 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 $ ownerSignsTransaction #&& valueCorrect
pure $ popaque (pconstant ()) pure $ popaque (pconstant ())
pure $ pif (0 #< mintedST) minting burning pure $ pif (0 #< mintedST) minting burning
@ -216,7 +214,7 @@ stakeValidator stake =
plam $ \datum redeemer ctx' -> unTermCont $ do plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- tclet $ pfromData ctx.txInfo 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 (pfromData -> stakeRedeemer, _) <- tctryFrom redeemer
@ -261,168 +259,185 @@ stakeValidator stake =
pure $ popaque (pconstant ()) pure $ popaque (pconstant ())
-------------------------------------------------------------------------- --------------------------------------------------------------------------
PRetractVotes _ -> unTermCont $ do -- Handle redeemers that require own stake output.
tcassert _ -> unTermCont $ do
"Owner signs this transaction" -- Filter out own output with own address and PST.
ownerSignsTransaction ownOutput <-
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 <-
tclet $ tclet $
pdata $ mustBePJust # "Own output should be present" #$ pfind
mkRecordConstr # plam
PStakeDatum ( \input -> unTermCont $ do
( #stakedAmount .= stakeDatum.stakedAmount inputF <- tcont $ pletFields @'["address", "value"] input
.& #owner .= stakeDatum.owner pure $
.& #lockedBy .= pdata expectedLocks inputF.address #== ownAddress
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
) )
# pfromData txInfoF.outputs
tcassert "A UTXO must exist with the correct output" $ stakeOut <-
-- FIXME: no need to pass the whole txInfo to 'anyOutput'. tclet $
anyOutput @PStakeDatum # txInfo mustFindDatum' @PStakeDatum
#$ plam # (pfield @"datumHash" # ownOutput)
$ \value address newStakeDatum' -> # txInfoF.datums
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)
pure $ popaque (pconstant ()) ownOutputValue <-
-------------------------------------------------------------------------- tclet $
PWitnessStake _ -> unTermCont $ do pfield @"value" # ownOutput
tcassert "ST at inputs must be 1" $
spentST #== 1
let AssetClass (propCs, propTn) = stake.proposalSTClass ownOutputValueUnchanged <-
propAssetClass = passetClass # pconstant propCs # pconstant propTn tclet $
proposalTokenMoved = pdata continuingValue #== pdata ownOutputValue
ptokenSpent
# propAssetClass
# txInfoF.inputs
-- In order for cosignature to be witnessed, it must be possible for a stakeOutUnchanged <-
-- proposal to allow this transaction to happen. This puts trust into the Proposal. tclet $
-- The Proposal must necessarily check that this is not abused. pdata stakeOut #== pdata stakeDatum'
tcassert
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)
tcassert "A UTXO must exist with the correct output" $ pure $
anyOutput @PStakeDatum # txInfo pmatch stakeRedeemer $ \case
#$ plam PRetractVotes _ -> unTermCont $ do
$ \value address newStakeDatum' -> tcassert
let isScriptAddress = pdata address #== ownAddress "Owner signs this transaction"
correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' ownerSignsTransaction
valueCorrect = pdata continuingValue #== pdata value
in pif tcassert "ST at inputs must be 1" $
isScriptAddress spentST #== 1
( foldl1
(#&&) -- This puts trust into the Proposal. The Proposal must necessarily check
[ ptraceIfFalse "valueCorrect" valueCorrect -- that this is not abused.
, ptraceIfFalse "correctOutputDatum" correctOutputDatum tcassert "Proposal ST spent" $
] spentProposalST #== 1
)
(pcon PFalse) tcassert "A UTXO must exist with the correct output" $
pure $ popaque (pconstant ()) unTermCont $ do
PDepositWithdraw r -> unTermCont $ do let valueCorrect = ownOutputValueUnchanged
tcassert "ST at inputs must be 1" $
spentST #== 1 -- TODO: check output datum is expected.
tcassert "Stake unlocked" $
pnot #$ stakeIsLocked pure $
tcassert foldl1
"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
(#&&) (#&&)
[ stakeDatum.owner #== newStakeDatum.owner [ ptraceIfFalse "valueCorrect" valueCorrect
, (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
] ]
pure $ pure $ popaque (pconstant ())
foldr1 --------------------------------------------------------------------------
(#&&) PPermitVote l -> unTermCont $ do
[ ptraceIfFalse "isScriptAddress" isScriptAddress tcassert
, ptraceIfFalse "correctOutputDatum" correctOutputDatum "Owner signs this transaction"
, ptraceIfFalse "valueCorrect" valueCorrect 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 ())

78
agora/Agora/Utils.hs
View file

@ -44,9 +44,6 @@ module Agora.Utils (
pmapMaybe, pmapMaybe,
-- * Functions which should (probably) not be upstreamed -- * Functions which should (probably) not be upstreamed
anyOutput,
allOutputs,
anyInput,
findTxOutByTxOutRef, findTxOutByTxOutRef,
scriptHashFromAddress, scriptHashFromAddress,
findOutputsToAddress, findOutputsToAddress,
@ -91,7 +88,6 @@ import Plutarch.Api.V1 (
PTokenName (PTokenName), PTokenName (PTokenName),
PTuple, PTuple,
PTxInInfo (PTxInInfo), PTxInInfo (PTxInInfo),
PTxInfo,
PTxOut (PTxOut), PTxOut (PTxOut),
PTxOutRef, PTxOutRef,
PValidatorHash, PValidatorHash,
@ -560,80 +556,6 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
All of these functions are quite inefficient. 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. -- | Create a value with a single asset class.
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
psingletonValue = phoistAcyclic $ psingletonValue = phoistAcyclic $