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

reduce use of unjustified punsafeCoerce

Browse source
This commit is contained in:
Emily Martins 2022-04-27 12:42:19 +02:00
parent 4ec0013af4
commit 0ca97a645a
7 changed files with 143 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

2
agora/Agora/AuthorityToken.hs
View file

@ -145,7 +145,7 @@ authorityTokenPolicy params =
( P.do
passert "Parent token did not move in minting GATs" govTokenSpent
passert "All outputs only emit valid GATs" $
allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
authorityTokensValidIn
# ownSymbol
# txOut

50
agora/Agora/Proposal.hs
View file

@ -26,6 +26,9 @@ module Agora.Proposal (
PProposalVotes (..),
PProposalId (..),
PResultTag (..),
-- * Plutarch helpers
proposalDatumValid,
) where
import GHC.Generics qualified as GHC
@ -41,13 +44,17 @@ import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
import Agora.SafeMoney (GTTag)
import Agora.Utils (pnotNull)
import Control.Applicative (Const)
import Control.Arrow (first)
import Plutarch.Builtin (PBuiltinMap)
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
import Plutarch.Lift (
DerivePConstantViaNewtype (..),
PConstantDecl,
PUnsafeLiftDecl (..),
)
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (PDiscrete, Tagged)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)
@ -348,6 +355,12 @@ newtype PProposalDatum (s :: S) = PProposalDatum
(PlutusType, PIsData, PDataFields)
via (PIsDataReprInstances PProposalDatum)
-- TODO: Derive this.
instance PTryFrom PData (PAsData PProposalDatum) where
type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
ptryFrom' d k =
k (punsafeCoerce d, ())
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
@ -364,6 +377,12 @@ data PProposalRedeemer (s :: S)
(PlutusType, PIsData)
via PIsDataReprInstances PProposalRedeemer
-- See below.
instance PTryFrom PData (PAsData PProposalRedeemer) where
type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
ptryFrom' d k =
k (punsafeCoerce d, ())
-- TODO: Waiting on PTryFrom for 'PPubKeyHash'
-- deriving via
-- PAsData (PIsDataReprInstances PProposalRedeemer)
@ -372,3 +391,34 @@ data PProposalRedeemer (s :: S)
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
--------------------------------------------------------------------------------
{- | Check for various invariants a proposal must uphold.
This can be used to check both upopn creation and
upon any following state transitions in the proposal.
-}
proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid =
phoistAcyclic $
plam $ \datum' -> P.do
datum <- pletFields @'["effects", "cosigners"] $ datum'
let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
effects =
-- JUSTIFICATION:
-- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@
-- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to
-- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@
punsafeCoerce datum.effects
atLeastOneNegativeResult :: Term _ PBool
atLeastOneNegativeResult =
pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
foldr1
(#&&)
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
, ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
, ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
]

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

@ -8,13 +8,11 @@ Plutus Scripts for Proposals.
module Agora.Proposal.Scripts (
proposalValidator,
proposalPolicy,
proposalDatumValid,
) where
import Agora.Proposal (
PProposalDatum (PProposalDatum),
PProposalRedeemer (..),
PResultTag,
Proposal (governorSTAssetClass, stakeSTAssetClass),
)
import Agora.Record (mkRecordConstr, (.&), (.=))
@ -23,27 +21,23 @@ import Agora.Utils (
anyOutput,
findTxOutByTxOutRef,
passert,
pnotNull,
psymbolValueOf,
ptokenSpent,
ptxSignedBy,
pvalueSpent,
)
import Plutarch.Api.V1 (
PDatumHash,
PMintingPolicy,
PScriptContext (PScriptContext),
PScriptPurpose (PMinting, PSpending),
PTxInfo (PTxInfo),
PValidator,
PValidatorHash,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Builtin (PBuiltinMap)
import Plutarch.Monadic qualified as P
import Plutarch.Unsafe (punsafeCoerce)
import Plutarch.TryFrom (ptryFrom)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
{- | Policy for Proposals.
@ -94,10 +88,8 @@ proposalValidator proposal =
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- pletFields @'["address", "value"] $ txOut
let proposalDatum :: Term _ Agora.Proposal.PProposalDatum
proposalDatum = pfromData $ punsafeCoerce datum
proposalRedeemer :: Term _ Agora.Proposal.PProposalRedeemer
proposalRedeemer = pfromData $ punsafeCoerce redeemer
(pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum
(pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer
proposalF <-
pletFields
@ -189,27 +181,3 @@ proposalValidator proposal =
spentST #== 1
popaque (pconstant ())
{- | Check for various invariants a proposal must uphold.
This can be used to check both upopn creation and
upon any following state transitions in the proposal.
-}
proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid =
phoistAcyclic $
plam $ \datum' -> P.do
datum <- pletFields @'["effects", "cosigners"] $ datum'
let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
effects = punsafeCoerce datum.effects
atLeastOneNegativeResult :: Term _ PBool
atLeastOneNegativeResult =
pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
foldr1
(#&&)
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
, ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
, ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
]

20
agora/Agora/Stake.hs
View file

@ -61,16 +61,17 @@ import Plutus.V1.Ledger.Value (AssetClass)
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
import Agora.SafeMoney (GTTag)
import Agora.Utils (
pfindDatum,
pnotNull,
ptryFindDatum,
)
import Control.Applicative (Const)
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
import Plutarch.Numeric ()
import Plutarch.SafeMoney (
PDiscrete,
Tagged (..),
)
import Plutarch.TryFrom (PTryFrom)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
--------------------------------------------------------------------------------
@ -191,6 +192,11 @@ newtype PStakeDatum (s :: S) = PStakeDatum
(PlutusType, PIsData, PDataFields)
via (PIsDataReprInstances PStakeDatum)
instance PTryFrom PData (PAsData PStakeDatum) where
type PTryFromExcess PData (PAsData PStakeDatum) = Const ()
ptryFrom' d k =
k (punsafeCoerce d, ())
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
@ -262,7 +268,7 @@ findStakeOwnedBy ::
:--> PPubKeyHash
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
:--> PBuiltinList (PAsData PTxInInfo)
:--> PMaybe PTxOut
:--> PMaybe (PAsData PStakeDatum)
)
findStakeOwnedBy = phoistAcyclic $
plam $ \ac pk datums inputs ->
@ -273,9 +279,8 @@ findStakeOwnedBy = phoistAcyclic $
txOutF <- pletFields @'["datumHash"] $ txOut
pmatch txOutF.datumHash $ \case
PDNothing _ -> pcon PNothing
PDJust ((pfield @"_0" #) -> dh) ->
-- TODO: PTryFrom here
punsafeCoerce $ pfindDatum # dh # datums
PDJust ((pfield @"_0" #) -> dh) -> P.do
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
stakeDatumOwnedBy =
@ -304,8 +309,7 @@ isInputStakeOwnedBy =
PDJust ((pfield @"_0" #) -> datumHash) ->
pif
(outStakeST #== 1)
-- TODO: use 'ptryFindDatum' instead in the future
( pmatch (pfindDatum # datumHash # datums) $ \case
( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case
PNothing -> pcon PFalse
PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
)

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

@ -35,7 +35,7 @@ import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.Extra (passetClass)
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Monadic qualified as P
import Plutarch.Numeric
@ -183,7 +183,12 @@ stakeValidator stake =
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass
-- Is the stake currently locked?
stakeIsLocked <- plet $ stakeLocked # stakeDatum'
@ -192,26 +197,76 @@ stakeValidator stake =
PDestroy _ -> P.do
passert "ST at inputs must be 1" $
spentST #== 1
passert "Should burn ST" $
mintedST #== -1
passert "Stake unlocked" $ pnot # stakeIsLocked
passert
"Owner signs this transaction"
ownerSignsTransaction
passert "Owner signs this transaction" ownerSignsTransaction
popaque (pconstant ())
--------------------------------------------------------------------------
PRetractVotes _ -> P.do
passert
"Owner signs this transaction"
ownerSignsTransaction
-- TODO: check proposal constraints
passert "ST at inputs must be 1" $
spentST #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
passert "Proposal ST spent" $
spentProposalST #== 1
passert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> P.do
let isScriptAddress = pdata address #== ownAddress
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value
pif
isScriptAddress
( foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
]
)
(pcon PFalse)
popaque (pconstant ())
--------------------------------------------------------------------------
PPermitVote _ -> P.do
passert
"Owner signs this transaction"
ownerSignsTransaction
-- TODO: check proposal constraints
passert "ST at inputs must be 1" $
spentST #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
passert "Proposal ST spent" $
spentProposalST #== 1
passert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> P.do
let isScriptAddress = pdata address #== ownAddress
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value
pif
isScriptAddress
( foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
]
)
(pcon PFalse)
popaque (pconstant ())
--------------------------------------------------------------------------
PWitnessStake _ -> P.do
@ -225,6 +280,9 @@ stakeValidator stake =
# 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.
passert
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)

8
agora/Agora/Utils.hs
View file

@ -84,7 +84,7 @@ pfindDatum = phoistAcyclic $
plam $ \datumHash datums -> plookupTuple # datumHash # datums
-- | Find a datum with the given hash, and `ptryFrom` it.
ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
ptryFindDatum = phoistAcyclic $
plam $ \datumHash inputs -> P.do
pmatch (pfindDatum # datumHash # inputs) $ \case
@ -326,6 +326,7 @@ ptokenSpent =
anyOutput ::
forall (datum :: PType) s.
( PIsData datum
, PTryFrom PData (PAsData datum)
) =>
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
anyOutput = phoistAcyclic $
@ -337,7 +338,7 @@ anyOutput = phoistAcyclic $
PTxOut txOut' <- pmatch (pfromData txOut'')
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- pmatch txOut.datumHash
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PJust datum -> P.do
predicate # txOut.value # txOut.address # pfromData datum
PNothing -> pcon PFalse
@ -348,6 +349,7 @@ anyOutput = phoistAcyclic $
allOutputs ::
forall (datum :: PType) s.
( PIsData datum
, PTryFrom PData (PAsData datum)
) =>
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
allOutputs = phoistAcyclic $
@ -359,7 +361,7 @@ allOutputs = phoistAcyclic $
PTxOut txOut' <- pmatch (pfromData txOut'')
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- pmatch txOut.datumHash
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PJust datum -> P.do
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
PNothing -> pcon PFalse