From 02bf6f49ccb31cb54eb897f4a7b0001fabcba994 Mon Sep 17 00:00:00 2001 From: fanghr Date: Mon, 23 May 2022 18:11:32 +0800 Subject: [PATCH 1/4] remove `anyInput` --- agora/Agora/Stake/Scripts.hs | 23 +++++++++++++++-------- agora/Agora/Utils.hs | 27 --------------------------- 2 files changed, 15 insertions(+), 35 deletions(-) diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index da9da7f..877819d 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -11,8 +11,8 @@ import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.SafeMoney (GTTag) import Agora.Stake import Agora.Utils ( - anyInput, anyOutput, + mustFindDatum', paddValue, pfindTxInByTxOutRef, pgeqByClass, @@ -77,7 +77,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 +92,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 ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index c594200..5cd6f40 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -46,7 +46,6 @@ module Agora.Utils ( -- * Functions which should (probably) not be upstreamed anyOutput, allOutputs, - anyInput, findTxOutByTxOutRef, scriptHashFromAddress, findOutputsToAddress, @@ -606,32 +605,6 @@ allOutputs = phoistAcyclic $ ) # 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 $ From 75c236db0193955b4e4093dda354bf34e7ea2c84 Mon Sep 17 00:00:00 2001 From: fanghr Date: Mon, 23 May 2022 18:20:49 +0800 Subject: [PATCH 2/4] remove `allOutputs` --- agora/Agora/AuthorityToken.hs | 13 +++++++------ agora/Agora/Utils.hs | 25 ------------------------- 2 files changed, 7 insertions(+), 31 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 9692ed3..06c5bb1 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -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 ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 5cd6f40..2ef0a90 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -45,7 +45,6 @@ module Agora.Utils ( -- * Functions which should (probably) not be upstreamed anyOutput, - allOutputs, findTxOutByTxOutRef, scriptHashFromAddress, findOutputsToAddress, @@ -581,30 +580,6 @@ anyOutput = phoistAcyclic $ ) # 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 - -- | Create a value with a single asset class. psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue = phoistAcyclic $ From ab12406f3dbb94a4fe0bb0fe8bb1d0335be04ad8 Mon Sep 17 00:00:00 2001 From: fanghr Date: Mon, 23 May 2022 23:18:18 +0800 Subject: [PATCH 3/4] remove `anyOutput` --- agora/Agora/Proposal/Scripts.hs | 43 ++--- agora/Agora/Stake/Scripts.hs | 285 +++++++++++++++++--------------- agora/Agora/Utils.hs | 26 --- 3 files changed, 163 insertions(+), 191 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 282ba26..1cc804b 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -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, @@ -346,34 +345,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 - ] + pforce proposalOutD #== expectedDatum pure $ popaque (pconstant ()) -------------------------------------------------------------------------- diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 877819d..8efd3ab 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -11,14 +11,12 @@ import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.SafeMoney (GTTag) import Agora.Stake import Agora.Utils ( - 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)) @@ -116,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 @@ -223,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 @@ -253,6 +244,43 @@ stakeValidator stake = -- Is the stake currently locked? stakeIsLocked <- tclet $ stakeLocked # stakeDatum' + -- Filter out own output with own address and PST. + -- Delay the evaluation cause in some cases there won't be any continuing output. + ownOutputD <- + 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 + + stakeOutD <- + tclet $ + pdelay $ + mustFindDatum' @PStakeDatum + # (pfield @"datumHash" # pforce ownOutputD) + # txInfoF.datums + + ownOutputValueD <- + tclet $ + pdelay $ + pfield @"value" # pforce ownOutputD + + ownOutputValueUnchangedD <- + tclet $ + pdelay $ + pdata continuingValue #== pdata (pforce ownOutputValueD) + + stakeOutUnchangedD <- + tclet $ + pdelay $ + pdata (pforce stakeOutD) #== pdata stakeDatum' + pure $ pmatch stakeRedeemer $ \case PDestroy _ -> unTermCont $ do @@ -282,20 +310,16 @@ stakeValidator stake = 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) + unTermCont $ do + let valueCorrect = pforce ownOutputValueUnchangedD + + -- TODO: check output datum is expected. + + pure $ + foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + ] pure $ popaque (pconstant ()) -------------------------------------------------------------------------- @@ -319,31 +343,21 @@ stakeValidator stake = expectedDatum <- tclet $ - pdata $ - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeDatum.stakedAmount - .& #owner .= stakeDatum.owner - .& #lockedBy .= pdata expectedLocks - ) + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeDatum.stakedAmount + .& #owner .= stakeDatum.owner + .& #lockedBy .= pdata expectedLocks + ) 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) + let correctOutputDatum = pdata (pforce stakeOutD) #== pdata expectedDatum + valueCorrect = pforce ownOutputValueUnchangedD + in foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" correctOutputDatum + ] pure $ popaque (pconstant ()) -------------------------------------------------------------------------- @@ -366,21 +380,13 @@ stakeValidator stake = (ownerSignsTransaction #|| proposalTokenMoved) 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) + let correctOutputDatum = pforce stakeOutUnchangedD + valueCorrect = pforce ownOutputValueUnchangedD + in foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "correctOutputDatum" correctOutputDatum + ] pure $ popaque (pconstant ()) PDepositWithdraw r -> unTermCont $ do tcassert "ST at inputs must be 1" $ @@ -391,45 +397,50 @@ stakeValidator stake = "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 - , (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) + unTermCont $ do + let stakeOut = pforce stakeOutD - -- 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 - ] + let oldStakedAmount = pfromData $ stakeDatum.stakedAmount + delta = pfromData $ pfield @"delta" # r - pure $ - foldr1 - (#&&) - [ ptraceIfFalse "isScriptAddress" isScriptAddress - , ptraceIfFalse "correctOutputDatum" correctOutputDatum - , ptraceIfFalse "valueCorrect" valueCorrect - ] + 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 + + ownOutputValue <- tclet $ pforce ownOutputValueD + + 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 ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 2ef0a90..8c16d85 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -44,7 +44,6 @@ module Agora.Utils ( pmapMaybe, -- * Functions which should (probably) not be upstreamed - anyOutput, findTxOutByTxOutRef, scriptHashFromAddress, findOutputsToAddress, @@ -87,7 +86,6 @@ import Plutarch.Api.V1 ( PTokenName (PTokenName), PTuple, PTxInInfo (PTxInInfo), - PTxInfo, PTxOut (PTxOut), PTxOutRef, PValidatorHash, @@ -556,30 +554,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 - -- | Create a value with a single asset class. psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue = phoistAcyclic $ From 297ccc91d9b970bfb4133dc5f75fc244b52e071d Mon Sep 17 00:00:00 2001 From: fanghr Date: Tue, 24 May 2022 21:48:32 +0800 Subject: [PATCH 4/4] use nested pmatches instead of laziness --- agora/Agora/Proposal/Scripts.hs | 34 ++-- agora/Agora/Stake/Scripts.hs | 329 ++++++++++++++++---------------- 2 files changed, 179 insertions(+), 184 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 1cc804b..0b0ceab 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -187,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 @@ -273,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 @@ -360,7 +358,7 @@ proposalValidator proposal = ) tcassert "Signatures are correctly added to cosignature list" $ - pforce proposalOutD #== expectedDatum + proposalOut #== expectedDatum pure $ popaque (pconstant ()) -------------------------------------------------------------------------- diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 8efd3ab..b333aae 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -244,43 +244,6 @@ stakeValidator stake = -- Is the stake currently locked? stakeIsLocked <- tclet $ stakeLocked # stakeDatum' - -- Filter out own output with own address and PST. - -- Delay the evaluation cause in some cases there won't be any continuing output. - ownOutputD <- - 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 - - stakeOutD <- - tclet $ - pdelay $ - mustFindDatum' @PStakeDatum - # (pfield @"datumHash" # pforce ownOutputD) - # txInfoF.datums - - ownOutputValueD <- - tclet $ - pdelay $ - pfield @"value" # pforce ownOutputD - - ownOutputValueUnchangedD <- - tclet $ - pdelay $ - pdata continuingValue #== pdata (pforce ownOutputValueD) - - stakeOutUnchangedD <- - tclet $ - pdelay $ - pdata (pforce stakeOutD) #== pdata stakeDatum' - pure $ pmatch stakeRedeemer $ \case PDestroy _ -> unTermCont $ do @@ -296,151 +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" $ - unTermCont $ do - let valueCorrect = pforce ownOutputValueUnchangedD - - -- TODO: check output datum is expected. - - pure $ - foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - ] - - 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 $ - 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" $ - let correctOutputDatum = pdata (pforce stakeOutD) #== pdata expectedDatum - valueCorrect = pforce ownOutputValueUnchangedD - in foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "datumCorrect" correctOutputDatum - ] + 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" $ - let correctOutputDatum = pforce stakeOutUnchangedD - valueCorrect = pforce ownOutputValueUnchangedD - 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 stakeOut = pforce stakeOutD + pure $ + pmatch stakeRedeemer $ \case + PRetractVotes _ -> unTermCont $ do + tcassert + "Owner signs this transaction" + ownerSignsTransaction - let oldStakedAmount = pfromData $ stakeDatum.stakedAmount - delta = pfromData $ pfield @"delta" # r + tcassert "ST at inputs must be 1" $ + spentST #== 1 - newStakedAmount <- tclet $ oldStakedAmount + delta + -- This puts trust into the Proposal. The Proposal must necessarily check + -- that this is not abused. + tcassert "Proposal ST spent" $ + spentProposalST #== 1 - tcassert "New staked amount shoudl be greater than or equal to 0" $ - zero #<= newStakedAmount + tcassert "A UTXO must exist with the correct output" $ + unTermCont $ do + let valueCorrect = ownOutputValueUnchanged - let expectedDatum = + -- TODO: check output datum is expected. + + pure $ + foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + ] + + 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 $ mkRecordConstr PStakeDatum - ( #stakedAmount .= pdata newStakedAmount + ( #stakedAmount .= stakeDatum.stakedAmount .& #owner .= stakeDatum.owner - .& #lockedBy .= stakeDatum.lockedBy + .& #lockedBy .= pdata expectedLocks ) - datumCorrect = stakeOut #== expectedDatum - ownOutputValue <- tclet $ pforce ownOutputValueD + tcassert "A UTXO must exist with the correct output" $ + let correctOutputDatum = stakeOut #== expectedDatum + valueCorrect = ownOutputValueUnchanged + in foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" correctOutputDatum + ] - let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta) + pure $ popaque (pconstant ()) + -------------------------------------------------------------------------- + PWitnessStake _ -> unTermCont $ do + tcassert "ST at inputs must be 1" $ + spentST #== 1 - valueCorrect = - foldr1 - (#&&) - [ pgeqByClass' (AssetClass ("", "")) - # ownOutputValue - # expectedValue - , pgeqByClass' (untag stake.gtClassRef) - # ownOutputValue - # expectedValue - , pgeqBySymbol - # stCurrencySymbol - # ownOutputValue - # expectedValue - ] + let AssetClass (propCs, propTn) = stake.proposalSTClass + propAssetClass = passetClass # pconstant propCs # pconstant propTn + proposalTokenMoved = + ptokenSpent + # propAssetClass + # txInfoF.inputs - pure $ - foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "datumCorrect" datumCorrect - ] + -- 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) - pure $ popaque (pconstant ()) + 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 ())