speed up test execution by precompiling scripts

x250 faster!
This commit is contained in:
Hongrui Fang 2022-08-10 17:38:21 +08:00
parent 91f7118ec3
commit 638dc2d0c6
No known key found for this signature in database
GPG key ID: 1E0454204FC7D755
18 changed files with 299 additions and 282 deletions

View file

@ -7,7 +7,7 @@ Property model and tests for 'Governor' related functions
-} -}
module Property.Governor (props) where module Property.Governor (props) where
import Agora.Governor (GovernorDatum (..), pisGovernorDatumValid) import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
import Agora.Governor.Scripts (governorPolicy) import Agora.Governor.Scripts (governorPolicy)
import Agora.Proposal ( import Agora.Proposal (
ProposalId (ProposalId), ProposalId (ProposalId),
@ -201,7 +201,7 @@ governorMintingProperty =
opaqueToUnit = plam $ \_ -> pconstant () opaqueToUnit = plam $ \_ -> pconstant ()
actual :: Term s (PScriptContext :--> PUnit) actual :: Term s (PScriptContext :--> PUnit)
actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor # pforgetData (pconstantData ()) # sc actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor.gstOutRef # pforgetData (pconstantData ()) # sc
classifier :: ScriptContext -> GovernorPolicyCases classifier :: ScriptContext -> GovernorPolicyCases
classifier sc classifier sc

View file

@ -17,6 +17,7 @@ import Agora.Effect.GovernorMutation (
) )
import Agora.Governor (GovernorDatum (..)) import Agora.Governor (GovernorDatum (..))
import Agora.Proposal (ProposalId (..), ProposalThresholds (..)) import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.Utils (validatorHashToTokenName)
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.Api.V1 (mkValidator, validatorHash)
@ -24,7 +25,6 @@ import PlutusLedgerApi.V1 (
Address, Address,
Datum (..), Datum (..),
ToData (..), ToData (..),
TokenName (..),
TxInInfo (..), TxInInfo (..),
TxInfo (..), TxInfo (..),
TxOut (..), TxOut (..),
@ -40,10 +40,11 @@ import PlutusLedgerApi.V1.Value qualified as Value (
singleton, singleton,
) )
import Sample.Shared ( import Sample.Shared (
agoraScripts,
authorityTokenSymbol, authorityTokenSymbol,
deterministicTracingConfing,
govAssetClass, govAssetClass,
govValidatorAddress, govValidatorAddress,
governor,
minAda, minAda,
signer, signer,
) )
@ -51,7 +52,7 @@ import Test.Util (datumPair, toDatumHash)
-- | The effect validator instance. -- | The effect validator instance.
effectValidator :: Validator effectValidator :: Validator
effectValidator = mkValidator def $ mutateGovernorValidator governor effectValidator = mkValidator deterministicTracingConfing $ mutateGovernorValidator agoraScripts
-- | The hash of the validator instance. -- | The hash of the validator instance.
effectValidatorHash :: ValidatorHash effectValidatorHash :: ValidatorHash
@ -65,17 +66,15 @@ effectValidatorAddress = scriptHashAddress effectValidatorHash
atAssetClass :: AssetClass atAssetClass :: AssetClass
atAssetClass = assetClass authorityTokenSymbol tokenName atAssetClass = assetClass authorityTokenSymbol tokenName
where where
-- TODO: use 'validatorHashToTokenName' tokenName = validatorHashToTokenName effectValidatorHash
ValidatorHash bs = effectValidatorHash
tokenName = TokenName bs
-- | The mock reference of the governor state UTXO. -- | The mock reference of the governor state UTXO.
govRef :: TxOutRef govRef :: TxOutRef
govRef = TxOutRef "614481d2159bfb72350222d61fce17e548e0fc00e5a1f841ff1837c431346ce7" 1 govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
-- | The mock reference of the effect UTXO. -- | The mock reference of the effect UTXO.
effectRef :: TxOutRef effectRef :: TxOutRef
effectRef = TxOutRef "c31164dc11835de7eb6187f67d0e1a19c1dfc0786a456923eef5043189cdb578" 1 effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
-- | The input effect datum in 'mkEffectTransaction'. -- | The input effect datum in 'mkEffectTransaction'.
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
@ -159,7 +158,7 @@ mkEffectTxInfo newGovDatum =
, txInfoValidRange = Interval.always , txInfoValidRange = Interval.always
, txInfoSignatories = [signer] , txInfoSignatories = [signer]
, txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum] , txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
, txInfoId = "4dae3806cc69615b721d52ed09b758f43f25a8f39b7934d6b28514caf71f5f7b" , txInfoId = "74c75505691e7baa981fa80e50b9b7e88dbe1eda67d4f062d89d203b"
} }
validNewGovernorDatum :: GovernorDatum validNewGovernorDatum :: GovernorDatum

View file

@ -28,7 +28,7 @@ import Plutarch.Api.V1 (mkValidator, validatorHash)
import PlutusLedgerApi.V1 ( import PlutusLedgerApi.V1 (
Address (Address), Address (Address),
Credential (..), Credential (..),
CurrencySymbol (CurrencySymbol), CurrencySymbol,
DatumHash (DatumHash), DatumHash (DatumHash),
PubKeyHash, PubKeyHash,
ScriptContext (..), ScriptContext (..),
@ -60,7 +60,7 @@ import Test.Util (scriptCredentials, userCredentials)
-- | A sample Currency Symbol. -- | A sample Currency Symbol.
currSymbol :: CurrencySymbol currSymbol :: CurrencySymbol
currSymbol = CurrencySymbol "12312099" currSymbol = "9c04a69c7133e26061fe5a15adaf4f79cd51e47ef22a2e3c91a36f04"
-- | A sample 'PubKeyHash'. -- | A sample 'PubKeyHash'.
signer :: PubKeyHash signer :: PubKeyHash

View file

@ -19,16 +19,20 @@ module Sample.Governor.Initialize (
mkTestCase, mkTestCase,
) where ) where
import Agora.Bootstrap (agoraScripts)
import Agora.Governor (Governor (..), GovernorDatum (..)) import Agora.Governor (Governor (..), GovernorDatum (..))
import Agora.Governor.Scripts ( import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
governorPolicy, import Agora.Proposal.Time (
governorSTAssetClassFromGovernor, MaxTimeRangeWidth (MaxTimeRangeWidth),
ProposalTimingConfig (ProposalTimingConfig),
)
import Agora.Scripts (
AgoraScripts (compiledGovernorPolicy),
governorSTAssetClass,
governorSTSymbol,
governorValidatorHash, governorValidatorHash,
) )
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalTimingConfig (ProposalTimingConfig))
import Data.Default (Default (..)) import Data.Default (Default (..))
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
@ -43,7 +47,6 @@ import Plutarch.Context (
) )
import PlutusLedgerApi.V1 ( import PlutusLedgerApi.V1 (
CurrencySymbol, CurrencySymbol,
MintingPolicy,
TxOutRef (TxOutRef), TxOutRef (TxOutRef),
ValidatorHash, ValidatorHash,
) )
@ -107,17 +110,17 @@ governor =
{ gstOutRef = witnessRef { gstOutRef = witnessRef
} }
scripts :: AgoraScripts
scripts = agoraScripts Shared.deterministicTracingConfing governor
govAssetClass :: AssetClass govAssetClass :: AssetClass
govAssetClass = governorSTAssetClassFromGovernor governor govAssetClass = governorSTAssetClass scripts
govValidatorHash :: ValidatorHash govValidatorHash :: ValidatorHash
govValidatorHash = governorValidatorHash governor govValidatorHash = governorValidatorHash scripts
govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy def (governorPolicy governor)
govSymbol :: CurrencySymbol govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy govSymbol = governorSTSymbol scripts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -271,6 +274,6 @@ mkTestCase name ps valid =
testPolicy testPolicy
valid valid
name name
(governorPolicy governor) scripts.compiledGovernorPolicy
() ()
(mkMinting mintGST ps govSymbol) (mkMinting mintGST ps govSymbol)

View file

@ -18,8 +18,8 @@ module Sample.Governor.Mutate (
import Agora.Effect.NoOp (noOpValidator) import Agora.Effect.NoOp (noOpValidator)
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..)) import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
import Agora.Scripts (AgoraScripts (..))
import Agora.Utils (validatorHashToTokenName) import Agora.Utils (validatorHashToTokenName)
import Data.Default (def) import Data.Default (def)
import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash) import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash)
@ -42,10 +42,10 @@ import PlutusLedgerApi.V1 (
) )
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared ( import Sample.Shared (
agoraScripts,
authorityTokenSymbol, authorityTokenSymbol,
govAssetClass, govAssetClass,
govValidatorHash, govValidatorHash,
governor,
minAda, minAda,
) )
import Test.Specification (SpecificationTree, testValidator) import Test.Specification (SpecificationTree, testValidator)
@ -219,7 +219,7 @@ mkTestCase name pb (Validity forGov) =
testValidator testValidator
forGov forGov
name name
(governorValidator governor) agoraScripts.compiledGovernorValidator
governorInputDatum governorInputDatum
governorRedeemer governorRedeemer
(mkSpending mutate pb governorRef) (mkSpending mutate pb governorRef)

View file

@ -37,15 +37,11 @@ module Sample.Proposal.Advance (
mkBadGovernorOutputDatumBundle, mkBadGovernorOutputDatumBundle,
) where ) where
import Agora.AuthorityToken (
AuthorityToken (AuthorityToken),
authorityTokenPolicy,
)
import Agora.Governor ( import Agora.Governor (
Governor (..),
GovernorDatum (..), GovernorDatum (..),
GovernorRedeemer (MintGATs), GovernorRedeemer (MintGATs),
) )
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (..), ProposalDatum (..),
ProposalId (ProposalId), ProposalId (ProposalId),
@ -56,7 +52,6 @@ import Agora.Proposal (
ResultTag (ResultTag), ResultTag (ResultTag),
emptyVotesFor, emptyVotesFor,
) )
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time ( import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig ( ProposalTimingConfig (
@ -66,12 +61,11 @@ import Agora.Proposal.Time (
votingTime votingTime
), ),
) )
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
Stake (gtClassRef),
StakeDatum (..), StakeDatum (..),
StakeRedeemer (WitnessStake), StakeRedeemer (WitnessStake),
) )
import Agora.Stake.Scripts (stakeValidator)
import Agora.Utils (validatorHashToTokenName) import Agora.Utils (validatorHashToTokenName)
import Control.Monad.State (execState, modify, when) import Control.Monad.State (execState, modify, when)
import Data.Default (def) import Data.Default (def)
@ -107,18 +101,18 @@ import Sample.Proposal.Shared (
stakeTxRef, stakeTxRef,
) )
import Sample.Shared ( import Sample.Shared (
agoraScripts,
authorityTokenSymbol, authorityTokenSymbol,
govAssetClass, govAssetClass,
govValidatorHash, govValidatorHash,
governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
import Sample.Shared qualified as Shared
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
group, group,
@ -394,7 +388,7 @@ mkStakeBuilder ps =
minAda minAda
<> Value.assetClassValue stakeAssetClass 1 <> Value.assetClassValue stakeAssetClass 1
<> Value.assetClassValue <> Value.assetClassValue
(untag stake.gtClassRef) (untag governor.gtClassRef)
ps.perStakeGTs ps.perStakeGTs
perStake idx i o = perStake idx i o =
let withSig = let withSig =
@ -565,7 +559,7 @@ mkTestTree name pb val =
testValidator testValidator
val.forProposalValidator val.forProposalValidator
"proposal" "proposal"
(proposalValidator Shared.proposal) agoraScripts.compiledProposalValidator
proposalInputDatum proposalInputDatum
proposalRedeemer proposalRedeemer
(spend proposalRef) (spend proposalRef)
@ -576,7 +570,7 @@ mkTestTree name pb val =
testValidator testValidator
val.forStakeValidator val.forStakeValidator
"stake" "stake"
(stakeValidator Shared.stake) agoraScripts.compiledStakeValidator
(getStakeInputDatumAt pb.stakeParameters idx) (getStakeInputDatumAt pb.stakeParameters idx)
stakeRedeemer stakeRedeemer
( spend (mkStakeRef idx) ( spend (mkStakeRef idx)
@ -586,7 +580,7 @@ mkTestTree name pb val =
testValidator testValidator
(fromJust val.forGovernorValidator) (fromJust val.forGovernorValidator)
"governor" "governor"
(governorValidator Shared.governor) agoraScripts.compiledGovernorValidator
governorInputDatum governorInputDatum
governorRedeemer governorRedeemer
(spend governorRef) (spend governorRef)
@ -596,7 +590,7 @@ mkTestTree name pb val =
testPolicy testPolicy
(fromJust val.forAuthorityTokenPolicy) (fromJust val.forAuthorityTokenPolicy)
"authority" "authority"
(authorityTokenPolicy $ AuthorityToken Shared.govAssetClass) agoraScripts.compiledAuthorityTokenPolicy
authorityTokenRedeemer authorityTokenRedeemer
(mint authorityTokenSymbol) (mint authorityTokenSymbol)
<$ (pb.authorityTokenParameters) <$ (pb.authorityTokenParameters)

View file

@ -14,6 +14,7 @@ module Sample.Proposal.Cosign (
mkTestTree, mkTestTree,
) where ) where
import Agora.Governor (Governor (..))
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (..), ProposalDatum (..),
ProposalId (ProposalId), ProposalId (ProposalId),
@ -22,19 +23,17 @@ import Agora.Proposal (
ResultTag (ResultTag), ResultTag (ResultTag),
emptyVotesFor, emptyVotesFor,
) )
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time ( import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime), ProposalTimingConfig (draftTime),
) )
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
Stake (gtClassRef),
StakeDatum (StakeDatum, owner), StakeDatum (StakeDatum, owner),
StakeRedeemer (WitnessStake), StakeRedeemer (WitnessStake),
stakedAmount, stakedAmount,
) )
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Default (def) import Data.Default (def)
import Data.List (sort) import Data.List (sort)
@ -61,15 +60,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef) import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts,
governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
import Sample.Shared qualified as Shared
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
group, group,
@ -149,7 +148,7 @@ cosign ps = builder
sortValue $ sortValue $
minAda minAda
<> Value.assetClassValue <> Value.assetClassValue
(untag stake.gtClassRef) (untag governor.gtClassRef)
(untag perStakedGTs) (untag perStakedGTs)
<> sst <> sst
@ -322,7 +321,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
in testValidator in testValidator
isValid isValid
"proposal" "proposal"
(proposalValidator Shared.proposal) agoraScripts.compiledProposalValidator
proposalInputDatum proposalInputDatum
(mkProposalRedeemer ps) (mkProposalRedeemer ps)
(spend proposalRef) (spend proposalRef)
@ -334,7 +333,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
in testValidator in testValidator
isValid isValid
"stake" "stake"
(stakeValidator Shared.stake) agoraScripts.compiledStakeValidator
stakeInputDatum stakeInputDatum
stakeRedeemer stakeRedeemer
(spend $ mkStakeRef idx) (spend $ mkStakeRef idx)

View file

@ -20,27 +20,24 @@ module Sample.Proposal.Create (
) where ) where
import Agora.Governor ( import Agora.Governor (
Governor (..),
GovernorDatum (..), GovernorDatum (..),
GovernorRedeemer (CreateProposal), GovernorRedeemer (CreateProposal),
) )
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal ( import Agora.Proposal (
Proposal (governorSTAssetClass),
ProposalDatum (..), ProposalDatum (..),
ProposalId (ProposalId), ProposalId (ProposalId),
ProposalStatus (..), ProposalStatus (..),
ResultTag (ResultTag), ResultTag (ResultTag),
emptyVotesFor, emptyVotesFor,
) )
import Agora.Proposal.Scripts (proposalPolicy)
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..)) import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..))
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
ProposalLock (..), ProposalLock (..),
Stake (gtClassRef),
StakeDatum (..), StakeDatum (..),
StakeRedeemer (PermitVote), StakeRedeemer (PermitVote),
) )
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Tagged (Tagged, untag) import Data.Tagged (Tagged, untag)
@ -69,19 +66,19 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (stakeTxRef) import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts,
govAssetClass,
govValidatorHash, govValidatorHash,
governor,
minAda, minAda,
proposal,
proposalPolicySymbol, proposalPolicySymbol,
proposalStartingTimeFromTimeRange, proposalStartingTimeFromTimeRange,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
signer2, signer2,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, group, testPolicy, testValidator) import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue) import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue)
@ -270,7 +267,7 @@ createProposal ps = builder
where where
pst = Value.singleton proposalPolicySymbol "" 1 pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1 sst = Value.assetClassValue stakeAssetClass 1
gst = Value.assetClassValue proposal.governorSTAssetClass 1 gst = Value.assetClassValue govAssetClass 1
--- ---
@ -279,7 +276,7 @@ createProposal ps = builder
sortValue $ sortValue $
sortValue $ sortValue $
sst sst
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakedGTs) <> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
<> minAda <> minAda
proposalValue = sortValue $ pst <> minAda proposalValue = sortValue $ pst <> minAda
@ -438,7 +435,7 @@ mkTestTree
testPolicy testPolicy
validForProposalPolicy validForProposalPolicy
"proposal" "proposal"
(proposalPolicy Shared.proposal.governorSTAssetClass) agoraScripts.compiledProposalPolicy
proposalPolicyRedeemer proposalPolicyRedeemer
(mint proposalPolicySymbol) (mint proposalPolicySymbol)
@ -446,15 +443,16 @@ mkTestTree
testValidator testValidator
validForGovernorValidator validForGovernorValidator
"governor" "governor"
(governorValidator Shared.governor) agoraScripts.compiledGovernorValidator
governorInputDatum governorInputDatum
governorRedeemer governorRedeemer
(spend governorRef) (spend governorRef)
stakeTest = stakeTest =
testValidator testValidator
validForStakeValidator validForStakeValidator
"stake" "stake"
(stakeValidator Shared.stake) agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps) (mkStakeInputDatum ps)
stakeRedeemer stakeRedeemer
(spend stakeRef) (spend stakeRef)

View file

@ -25,6 +25,7 @@ module Sample.Proposal.UnlockStake (
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Agora.Governor (Governor (..))
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (..), ProposalDatum (..),
ProposalId (..), ProposalId (..),
@ -33,10 +34,9 @@ import Agora.Proposal (
ProposalVotes (..), ProposalVotes (..),
ResultTag (..), ResultTag (..),
) )
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.Stake (ProposalLock (..), Stake (..), StakeDatum (..), StakeRedeemer (RetractVotes)) import Agora.Scripts (AgoraScripts (..))
import Agora.Stake.Scripts (stakeValidator) import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..), untag) import Data.Tagged (Tagged (..), untag)
import Plutarch.Context ( import Plutarch.Context (
@ -59,15 +59,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (stakeTxRef) import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts,
governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, group, testValidator) import Test.Specification (SpecificationTree, group, testValidator)
import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap) import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
@ -277,7 +277,7 @@ unlockStake ps =
sortValue $ sortValue $
mconcat mconcat
[ Value.assetClassValue [ Value.assetClassValue
(untag stake.gtClassRef) (untag governor.gtClassRef)
(untag defStakedGTs) (untag defStakedGTs)
, sst , sst
, minAda , minAda
@ -532,7 +532,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
testValidator testValidator
(not ps.alterOutputStake) (not ps.alterOutputStake)
"stake" "stake"
(stakeValidator Shared.stake) agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps) (mkStakeInputDatum ps)
stakeRedeemer stakeRedeemer
(spend stakeRef) (spend stakeRef)
@ -544,7 +544,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
in testValidator in testValidator
isValid isValid
"proposal" "proposal"
(proposalValidator Shared.proposal) agoraScripts.compiledProposalValidator
(mkProposalInputDatum ps pid) (mkProposalInputDatum ps pid)
proposalRedeemer proposalRedeemer
(spend ref) (spend ref)

View file

@ -11,6 +11,7 @@ module Sample.Proposal.Vote (
validVoteAsDelegateParameters, validVoteAsDelegateParameters,
) where ) where
import Agora.Governor (Governor (..))
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (..), ProposalDatum (..),
ProposalId (ProposalId), ProposalId (ProposalId),
@ -19,18 +20,16 @@ import Agora.Proposal (
ProposalVotes (ProposalVotes), ProposalVotes (ProposalVotes),
ResultTag (ResultTag), ResultTag (ResultTag),
) )
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time ( import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime, votingTime), ProposalTimingConfig (draftTime, votingTime),
) )
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
ProposalLock (..), ProposalLock (..),
Stake (gtClassRef),
StakeDatum (..), StakeDatum (..),
StakeRedeemer (PermitVote), StakeRedeemer (PermitVote),
) )
import Agora.Stake.Scripts (stakeValidator)
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Tagged (Tagged (Tagged), untag) import Data.Tagged (Tagged (Tagged), untag)
import Plutarch.Context ( import Plutarch.Context (
@ -52,15 +51,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef) import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts,
governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
import Sample.Shared qualified as Shared
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
group, group,
@ -205,7 +204,7 @@ vote params =
stakeValue = stakeValue =
sortValue $ sortValue $
sst sst
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount <> Value.assetClassValue (untag governor.gtClassRef) params.voteCount
<> minAda <> minAda
signer = signer =
@ -278,7 +277,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
testValidator testValidator
isValid isValid
"proposal" "proposal"
(proposalValidator Shared.proposal) agoraScripts.compiledProposalValidator
proposalInputDatum proposalInputDatum
(mkProposalRedeemer ps) (mkProposalRedeemer ps)
(spend proposalRef) (spend proposalRef)
@ -287,7 +286,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
let stakeInputDatum = mkStakeInputDatum ps let stakeInputDatum = mkStakeInputDatum ps
in validatorSucceedsWith in validatorSucceedsWith
"stake" "stake"
(stakeValidator Shared.stake) agoraScripts.compiledStakeValidator
stakeInputDatum stakeInputDatum
stakeRedeemer stakeRedeemer
(spend stakeRef) (spend stakeRef)

View file

@ -12,11 +12,15 @@ module Sample.Shared (
signer, signer,
signer2, signer2,
minAda, minAda,
deterministicTracingConfing,
mkEffect,
-- * Agora Scripts
agoraScripts,
-- * Components -- * Components
-- ** Stake -- ** Stake
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
stakeAddress, stakeAddress,
@ -33,14 +37,12 @@ module Sample.Shared (
gstUTXORef, gstUTXORef,
-- ** Proposal -- ** Proposal
proposal,
proposalPolicySymbol, proposalPolicySymbol,
proposalValidatorHash, proposalValidatorHash,
proposalValidatorAddress, proposalValidatorAddress,
proposalStartingTimeFromTimeRange, proposalStartingTimeFromTimeRange,
-- ** Authority -- ** Authority
authorityToken,
authorityTokenSymbol, authorityTokenSymbol,
-- ** Treasury -- ** Treasury
@ -53,38 +55,29 @@ module Sample.Shared (
wrongEffHash, wrongEffHash,
) where ) where
import Agora.AuthorityToken (AuthorityToken) import Agora.Bootstrap qualified as Bootstrap
import Agora.Effect.NoOp (noOpValidator) import Agora.Effect.NoOp (noOpValidator)
import Agora.Governor (Governor (Governor)) import Agora.Governor (Governor (Governor))
import Agora.Governor.Scripts ( import Agora.Proposal (ProposalThresholds (..))
authorityTokenFromGovernor,
authorityTokenSymbolFromGovernor,
governorPolicy,
governorSTAssetClassFromGovernor,
governorValidator,
governorValidatorHash,
proposalFromGovernor,
proposalSTSymbolFromGovernor,
proposalValidatorHashFromGovernor,
stakeFromGovernor,
stakeSTAssetClassFromGovernor,
stakeSTSymbolFromGovernor,
stakeValidatorHashFromGovernor,
)
import Agora.Proposal (Proposal (..), ProposalThresholds (..))
import Agora.Proposal.Time ( import Agora.Proposal.Time (
MaxTimeRangeWidth (..), MaxTimeRangeWidth (..),
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (..), ProposalTimingConfig (..),
) )
import Agora.Stake (Stake (..)) import Agora.Scripts qualified as Scripts
import Agora.Treasury (treasuryValidator) import Agora.Treasury (treasuryValidator)
import Agora.Utils (validatorHashToTokenName) import Agora.Utils (
CompiledEffect (CompiledEffect),
CompiledMintingPolicy (getCompiledMintingPolicy),
CompiledValidator (getCompiledValidator),
validatorHashToTokenName,
)
import Data.Default.Class (Default (..)) import Data.Default.Class (Default (..))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Plutarch (Config (..), TracingMode (DetTracing))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PValidator,
mintingPolicySymbol, mintingPolicySymbol,
mkMintingPolicy,
mkValidator, mkValidator,
validatorHash, validatorHash,
) )
@ -110,24 +103,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
assetClass, assetClass,
singleton, singleton,
) )
import PlutusTx qualified
stake :: Stake -- Plutarch compiler configauration.
stake = stakeFromGovernor governor -- TODO: add the ability to change this value. Maybe wrap everything in a
-- Reader monad?
stakeSymbol :: CurrencySymbol deterministicTracingConfing :: Config
stakeSymbol = stakeSTSymbolFromGovernor governor deterministicTracingConfing = Config DetTracing
stakeAssetClass :: AssetClass
stakeAssetClass = stakeSTAssetClassFromGovernor governor
stakeValidatorHash :: ValidatorHash
stakeValidatorHash = stakeValidatorHashFromGovernor governor
stakeAddress :: Address
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
gstUTXORef :: TxOutRef
gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
governor :: Governor governor :: Governor
governor = Governor oref gt mc governor = Governor oref gt mc
@ -140,29 +122,44 @@ governor = Governor oref gt mc
"LQ" "LQ"
mc = 20 mc = 20
agoraScripts :: Scripts.AgoraScripts
agoraScripts = Bootstrap.agoraScripts deterministicTracingConfing governor
stakeSymbol :: CurrencySymbol
stakeSymbol = Scripts.stakeSTSymbol agoraScripts
stakeAssetClass :: AssetClass
stakeAssetClass = Scripts.stakeSTAssetClass agoraScripts
stakeValidatorHash :: ValidatorHash
stakeValidatorHash = Scripts.stakeValidatorHash agoraScripts
stakeAddress :: Address
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
gstUTXORef :: TxOutRef
gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
govPolicy :: MintingPolicy govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy def (governorPolicy governor) govPolicy = getCompiledMintingPolicy $ agoraScripts.compiledGovernorPolicy
govValidator :: Validator govValidator :: Validator
govValidator = mkValidator def (governorValidator governor) govValidator = getCompiledValidator $ agoraScripts.compiledGovernorValidator
govSymbol :: CurrencySymbol govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy govSymbol = mintingPolicySymbol govPolicy
govAssetClass :: AssetClass govAssetClass :: AssetClass
govAssetClass = governorSTAssetClassFromGovernor governor govAssetClass = Scripts.governorSTAssetClass agoraScripts
govValidatorHash :: ValidatorHash govValidatorHash :: ValidatorHash
govValidatorHash = governorValidatorHash governor govValidatorHash = Scripts.governorValidatorHash agoraScripts
govValidatorAddress :: Address govValidatorAddress :: Address
govValidatorAddress = scriptHashAddress govValidatorHash govValidatorAddress = scriptHashAddress govValidatorHash
proposal :: Proposal
proposal = proposalFromGovernor governor
proposalPolicySymbol :: CurrencySymbol proposalPolicySymbol :: CurrencySymbol
proposalPolicySymbol = proposalSTSymbolFromGovernor governor proposalPolicySymbol = Scripts.proposalSTSymbol agoraScripts
-- | A sample 'PubKeyHash'. -- | A sample 'PubKeyHash'.
signer :: PubKeyHash signer :: PubKeyHash
@ -173,7 +170,7 @@ signer2 :: PubKeyHash
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192" signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
proposalValidatorHash :: ValidatorHash proposalValidatorHash :: ValidatorHash
proposalValidatorHash = proposalValidatorHashFromGovernor governor proposalValidatorHash = Scripts.proposalValidatoHash agoraScripts
proposalValidatorAddress :: Address proposalValidatorAddress :: Address
proposalValidatorAddress = scriptHashAddress proposalValidatorHash proposalValidatorAddress = scriptHashAddress proposalValidatorHash
@ -189,11 +186,8 @@ instance Default ProposalThresholds where
, vote = Tagged 100 , vote = Tagged 100
} }
authorityToken :: AuthorityToken
authorityToken = authorityTokenFromGovernor governor
authorityTokenSymbol :: CurrencySymbol authorityTokenSymbol :: CurrencySymbol
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor authorityTokenSymbol = Scripts.authorityTokenSymbol agoraScripts
{- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'. {- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
For testing purpose only. For testing purpose only.
@ -222,6 +216,9 @@ proposalStartingTimeFromTimeRange
ProposalStartingTime $ (l + u) `div` 2 ProposalStartingTime $ (l + u) `div` 2
proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed" proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed"
mkEffect :: (PlutusTx.ToData datum) => ClosedTerm PValidator -> CompiledEffect datum
mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
------------------------------------------------------------------ ------------------------------------------------------------------
treasuryOut :: TxOut treasuryOut :: TxOut

View file

@ -6,10 +6,8 @@ Description: Sample based testing for Stake utxos
This module tests primarily the happy path for Stake creation This module tests primarily the happy path for Stake creation
-} -}
module Sample.Stake ( module Sample.Stake (
stake,
stakeAssetClass, stakeAssetClass,
stakeSymbol, stakeSymbol,
validatorHashTN,
signer, signer,
-- * Script contexts -- * Script contexts
@ -20,15 +18,12 @@ module Sample.Stake (
DepositWithdrawExample (..), DepositWithdrawExample (..),
) where ) where
import Agora.Governor (Governor (gtClassRef))
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Stake ( import Agora.Stake (
Stake (gtClassRef),
StakeDatum (StakeDatum, stakedAmount), StakeDatum (StakeDatum, stakedAmount),
) )
import Agora.Stake.Scripts (stakeValidator)
import Data.Default (def)
import Data.Tagged (Tagged, untag) import Data.Tagged (Tagged, untag)
import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutarch.Context ( import Plutarch.Context (
MintingBuilder, MintingBuilder,
SpendingBuilder, SpendingBuilder,
@ -51,9 +46,7 @@ import PlutusLedgerApi.V1 (
ScriptContext (..), ScriptContext (..),
ScriptPurpose (Minting), ScriptPurpose (Minting),
ToData (toBuiltinData), ToData (toBuiltinData),
TokenName (TokenName),
TxInfo (txInfoData, txInfoSignatories), TxInfo (txInfoData, txInfoSignatories),
ValidatorHash (ValidatorHash),
) )
import PlutusLedgerApi.V1.Contexts (TxOutRef (..)) import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
import PlutusLedgerApi.V1.Value qualified as Value ( import PlutusLedgerApi.V1.Value qualified as Value (
@ -61,19 +54,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
singleton, singleton,
) )
import Sample.Shared ( import Sample.Shared (
governor,
signer, signer,
stake,
stakeAssetClass, stakeAssetClass,
stakeSymbol, stakeSymbol,
stakeValidatorHash, stakeValidatorHash,
) )
import Test.Util (sortValue)
-- | 'TokenName' that represents the hash of the 'Stake' validator.
validatorHashTN :: TokenName
validatorHashTN =
let validator = mkValidator def $ stakeValidator stake
ValidatorHash vh = validatorHash validator
in TokenName vh
-- | This script context should be a valid transaction. -- | This script context should be a valid transaction.
stakeCreation :: ScriptContext stakeCreation :: ScriptContext
@ -151,14 +138,22 @@ stakeDepositWithdraw config =
, input $ , input $
mconcat mconcat
[ script stakeValidatorHash [ script stakeValidatorHash
, withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)) , withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount)
)
, withDatum stakeAfter , withDatum stakeAfter
, withOutRef stakeRef , withOutRef stakeRef
] ]
, output $ , output $
mconcat mconcat
[ script stakeValidatorHash [ script stakeValidatorHash
, withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)) , withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount)
)
, withDatum stakeAfter , withDatum stakeAfter
] ]
, withSpendingOutRef stakeRef , withSpendingOutRef stakeRef

View file

@ -19,12 +19,12 @@ module Sample.Stake.SetDelegate (
delegateToOwnerParameters, delegateToOwnerParameters,
) where ) where
import Agora.Governor (Governor (gtClassRef))
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
Stake (gtClassRef),
StakeDatum (..), StakeDatum (..),
StakeRedeemer (ClearDelegate, DelegateTo), StakeRedeemer (ClearDelegate, DelegateTo),
) )
import Agora.Stake.Scripts (stakeValidator)
import Data.Tagged (untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
SpendingBuilder, SpendingBuilder,
@ -46,10 +46,11 @@ import PlutusLedgerApi.V1 (
) )
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared ( import Sample.Shared (
agoraScripts,
governor,
minAda, minAda,
signer, signer,
signer2, signer2,
stake,
stakeAssetClass, stakeAssetClass,
stakeValidatorHash, stakeValidatorHash,
) )
@ -118,7 +119,7 @@ setDelegate ps = buildSpendingUnsafe builder
mconcat mconcat
[ st [ st
, Value.assetClassValue , Value.assetClassValue
(untag stake.gtClassRef) (untag governor.gtClassRef)
(untag stakeInput.stakedAmount) (untag stakeInput.stakedAmount)
, minAda , minAda
] ]
@ -154,7 +155,7 @@ mkTestCase name ps valid =
testValidator testValidator
valid valid
name name
(stakeValidator stake) agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps) (mkStakeInputDatum ps)
(mkStakeRedeemer ps) (mkStakeRedeemer ps)
(setDelegate ps) (setDelegate ps)

View file

@ -2,8 +2,8 @@ module Spec.Effect.GovernorMutation (specs) where
import Agora.Effect.GovernorMutation (mutateGovernorValidator) import Agora.Effect.GovernorMutation (mutateGovernorValidator)
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (..)) import Agora.Proposal (ProposalId (..))
import Agora.Scripts (AgoraScripts (..))
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending)) import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
import Sample.Effect.GovernorMutation ( import Sample.Effect.GovernorMutation (
@ -14,7 +14,7 @@ import Sample.Effect.GovernorMutation (
mkEffectTxInfo, mkEffectTxInfo,
validNewGovernorDatum, validNewGovernorDatum,
) )
import Sample.Shared qualified as Shared import Sample.Shared (agoraScripts, mkEffect)
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
effectFailsWith, effectFailsWith,
@ -32,7 +32,7 @@ specs =
"valid new governor datum" "valid new governor datum"
[ validatorSucceedsWith [ validatorSucceedsWith
"governor validator should pass" "governor validator should pass"
(governorValidator Shared.governor) agoraScripts.compiledGovernorValidator
( GovernorDatum ( GovernorDatum
def def
(ProposalId 0) (ProposalId 0)
@ -47,7 +47,7 @@ specs =
) )
, effectSucceedsWith , effectSucceedsWith
"effect validator should pass" "effect validator should pass"
(mutateGovernorValidator Shared.governor) (mkEffect $ mutateGovernorValidator agoraScripts)
(mkEffectDatum validNewGovernorDatum) (mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef)) (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
] ]
@ -55,7 +55,7 @@ specs =
"invalid new governor datum" "invalid new governor datum"
[ validatorFailsWith [ validatorFailsWith
"governor validator should fail" "governor validator should fail"
(governorValidator Shared.governor) agoraScripts.compiledGovernorValidator
( GovernorDatum ( GovernorDatum
def def
(ProposalId 0) (ProposalId 0)
@ -70,7 +70,7 @@ specs =
) )
, effectFailsWith , effectFailsWith
"effect validator should fail" "effect validator should fail"
(mutateGovernorValidator Shared.governor) (mkEffect $ mutateGovernorValidator agoraScripts)
(mkEffectDatum validNewGovernorDatum) (mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef)) (ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
] ]

View file

@ -25,12 +25,14 @@ import Sample.Effect.TreasuryWithdrawal (
treasuries, treasuries,
users, users,
) )
import Sample.Shared (mkEffect)
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
effectFailsWith, effectFailsWith,
effectSucceedsWith, effectSucceedsWith,
group, group,
) )
import Test.Util (sortValue)
specs :: [SpecificationTree] specs :: [SpecificationTree]
specs = specs =
@ -38,7 +40,7 @@ specs =
"effect" "effect"
[ effectSucceedsWith [ effectSucceedsWith
"Simple" "Simple"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum1 datum1
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -50,7 +52,7 @@ specs =
) )
, effectSucceedsWith , effectSucceedsWith
"Simple with multiple treasuries " "Simple with multiple treasuries "
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum1 datum1
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -67,7 +69,7 @@ specs =
) )
, effectSucceedsWith , effectSucceedsWith
"Mixed Assets" "Mixed Assets"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2 datum2
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -82,7 +84,7 @@ specs =
) )
, effectFailsWith , effectFailsWith
"Pay to uknown 3rd party" "Pay to uknown 3rd party"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2 datum2
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -98,7 +100,7 @@ specs =
) )
, effectFailsWith , effectFailsWith
"Missing receiver" "Missing receiver"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2 datum2
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -113,7 +115,7 @@ specs =
) )
, effectFailsWith , effectFailsWith
"Unauthorized treasury" "Unauthorized treasury"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum3 datum3
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -125,7 +127,7 @@ specs =
) )
, effectFailsWith , effectFailsWith
"Prevent transactions besides the withdrawal" "Prevent transactions besides the withdrawal"
(treasuryWithdrawalValidator currSymbol) (mkEffect $ treasuryWithdrawalValidator currSymbol)
datum3 datum3
( buildScriptContext ( buildScriptContext
[ inputGAT [ inputGAT
@ -141,8 +143,14 @@ specs =
] ]
] ]
where where
asset1 = Value.singleton "abbc12" "OrangeBottle" asset1 =
asset2 = Value.singleton "abbc12" "19721121" Value.singleton
"0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
"OrangeBottle"
asset2 =
Value.singleton
"7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
"19721121"
datum1 = datum1 =
TreasuryWithdrawalDatum TreasuryWithdrawalDatum
[ (head users, asset1 1) [ (head users, asset1 1)
@ -155,8 +163,8 @@ specs =
] ]
datum2 = datum2 =
TreasuryWithdrawalDatum TreasuryWithdrawalDatum
[ (head users, asset2 5 <> asset1 4) [ (head users, sortValue $ asset2 5 <> asset1 4)
, (users !! 1, asset2 1 <> asset1 2) , (users !! 1, sortValue $ asset2 1 <> asset1 2)
, (users !! 2, asset1 1) , (users !! 2, asset1 1)
] ]
[ head treasuries [ head treasuries

View file

@ -9,14 +9,14 @@ Tests for Stake policy and validator
-} -}
module Spec.Stake (specs) where module Spec.Stake (specs) where
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
Stake (..),
StakeDatum (StakeDatum), StakeDatum (StakeDatum),
StakeRedeemer (DepositWithdraw), StakeRedeemer (DepositWithdraw),
) )
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Data.Bool (Bool (..)) import Data.Bool (Bool (..))
import Data.Maybe (Maybe (..)) import Data.Maybe (Maybe (..))
import Sample.Shared (agoraScripts)
import Sample.Stake ( import Sample.Stake (
DepositWithdrawExample ( DepositWithdrawExample (
DepositWithdrawExample, DepositWithdrawExample,
@ -26,7 +26,6 @@ import Sample.Stake (
signer, signer,
) )
import Sample.Stake qualified as Stake ( import Sample.Stake qualified as Stake (
stake,
stakeCreation, stakeCreation,
stakeCreationUnsigned, stakeCreationUnsigned,
stakeCreationWrongDatum, stakeCreationWrongDatum,
@ -41,7 +40,6 @@ import Test.Specification (
validatorFailsWith, validatorFailsWith,
validatorSucceedsWith, validatorSucceedsWith,
) )
import Test.Util (toDatum)
import Prelude (Num (negate), ($)) import Prelude (Num (negate), ($))
-- | The SpecificationTree exported by this module. -- | The SpecificationTree exported by this module.
@ -51,17 +49,17 @@ specs =
"policy" "policy"
[ policySucceedsWith [ policySucceedsWith
"stakeCreation" "stakeCreation"
(stakePolicy Stake.stake.gtClassRef) agoraScripts.compiledStakePolicy
() ()
Stake.stakeCreation Stake.stakeCreation
, policyFailsWith , policyFailsWith
"stakeCreationWrongDatum" "stakeCreationWrongDatum"
(stakePolicy Stake.stake.gtClassRef) agoraScripts.compiledStakePolicy
() ()
Stake.stakeCreationWrongDatum Stake.stakeCreationWrongDatum
, policyFailsWith , policyFailsWith
"stakeCreationUnsigned" "stakeCreationUnsigned"
(stakePolicy Stake.stake.gtClassRef) agoraScripts.compiledStakePolicy
() ()
Stake.stakeCreationUnsigned Stake.stakeCreationUnsigned
] ]
@ -69,21 +67,21 @@ specs =
"validator" "validator"
[ validatorSucceedsWith [ validatorSucceedsWith
"stakeDepositWithdraw deposit" "stakeDepositWithdraw deposit"
(stakeValidator Stake.stake) agoraScripts.compiledStakeValidator
(toDatum $ StakeDatum 100_000 signer Nothing []) (StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw 100_000) (DepositWithdraw 100_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000}) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
, validatorSucceedsWith , validatorSucceedsWith
"stakeDepositWithdraw withdraw" "stakeDepositWithdraw withdraw"
(stakeValidator Stake.stake) agoraScripts.compiledStakeValidator
(toDatum $ StakeDatum 100_000 signer Nothing []) (StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw $ negate 100_000) (DepositWithdraw $ negate 100_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000}) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
, validatorFailsWith , validatorFailsWith
"stakeDepositWithdraw negative GT" "stakeDepositWithdraw negative GT"
(stakeValidator Stake.stake) agoraScripts.compiledStakeValidator
(toDatum $ StakeDatum 100_000 signer Nothing []) (StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw 1_000_000) (DepositWithdraw 1_000_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000}) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
, group , group
"set delegate" "set delegate"

View file

@ -25,6 +25,8 @@ import Agora.Treasury (
TreasuryRedeemer (SpendTreasuryGAT), TreasuryRedeemer (SpendTreasuryGAT),
treasuryValidator, treasuryValidator,
) )
import Agora.Utils (CompiledValidator (CompiledValidator))
import Plutarch.Api.V1 (mkValidator)
import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey)) import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey))
import PlutusLedgerApi.V1.Contexts ( import PlutusLedgerApi.V1.Contexts (
ScriptContext (scriptContextPurpose, scriptContextTxInfo), ScriptContext (scriptContextPurpose, scriptContextTxInfo),
@ -35,7 +37,7 @@ import PlutusLedgerApi.V1.Credential (
StakingCredential (StakingHash), StakingCredential (StakingHash),
) )
import PlutusLedgerApi.V1.Value qualified as Value (singleton) import PlutusLedgerApi.V1.Value qualified as Value (singleton)
import Sample.Shared (trCredential) import Sample.Shared (deterministicTracingConfing, trCredential)
import Sample.Treasury ( import Sample.Treasury (
gatCs, gatCs,
gatTn, gatTn,
@ -51,6 +53,12 @@ import Test.Specification (
validatorSucceedsWith, validatorSucceedsWith,
) )
compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
compiledTreasuryValidator =
CompiledValidator $
mkValidator deterministicTracingConfing $
treasuryValidator gatCs
specs :: [SpecificationTree] specs :: [SpecificationTree]
specs = specs =
[ group [ group
@ -59,7 +67,7 @@ specs =
"Positive" "Positive"
[ validatorSucceedsWith [ validatorSucceedsWith
"Allows for effect changes" "Allows for effect changes"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
validCtx validCtx
@ -70,7 +78,7 @@ specs =
"Fails with ScriptPurpose not Minting" "Fails with ScriptPurpose not Minting"
[ validatorFailsWith [ validatorFailsWith
"Spending" "Spending"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
validCtx validCtx
@ -78,7 +86,7 @@ specs =
} }
, validatorFailsWith , validatorFailsWith
"Rewarding" "Rewarding"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
validCtx validCtx
@ -88,7 +96,7 @@ specs =
} }
, validatorFailsWith , validatorFailsWith
"Certifying" "Certifying"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
validCtx validCtx
@ -100,7 +108,7 @@ specs =
] ]
, validatorFailsWith -- TODO: Use QuickCheck. , validatorFailsWith -- TODO: Use QuickCheck.
"Fails when multiple GATs burned" "Fails when multiple GATs burned"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
validCtx validCtx
@ -115,13 +123,13 @@ specs =
} }
, validatorFailsWith , validatorFailsWith
"Fails when GAT token name is not script address" "Fails when GAT token name is not script address"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
trCtxGATNameNotAddress trCtxGATNameNotAddress
, validatorFailsWith , validatorFailsWith
"Fails with wallet as input" "Fails with wallet as input"
(treasuryValidator gatCs) compiledTreasuryValidator
() ()
SpendTreasuryGAT SpendTreasuryGAT
( let txInfo = validCtx.scriptContextTxInfo ( let txInfo = validCtx.scriptContextTxInfo

View file

@ -49,12 +49,18 @@ module Test.Specification (
toTestTree, toTestTree,
) where ) where
import Plutarch.Api.V1 (PMintingPolicy, PValidator) import Agora.Utils (CompiledEffect (..), CompiledMintingPolicy (..), CompiledValidator (..))
import Plutarch.Builtin (pforgetData) import Control.Composition ((.**), (.***))
import Data.Coerce (coerce)
import Plutarch.Evaluate (evalScript) import Plutarch.Evaluate (evalScript)
import Plutarch.Extra.Compile (mustCompile) import PlutusLedgerApi.V1 (
import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) Datum (..),
import PlutusLedgerApi.V1 (Script, ScriptContext) Redeemer (Redeemer),
Script,
ScriptContext,
ToData (toBuiltinData),
)
import PlutusLedgerApi.V1.Scripts (Context (..), applyMintingPolicyScript, applyValidator)
import PlutusTx.IsData qualified as PlutusTx (ToData) import PlutusTx.IsData qualified as PlutusTx (ToData)
import Test.Tasty (TestTree, testGroup) import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase) import Test.Tasty.HUnit (assertFailure, testCase)
@ -153,122 +159,133 @@ scriptSucceeds name script = Terminal $ Specification name Success script
scriptFails :: String -> Script -> SpecificationTree scriptFails :: String -> Script -> SpecificationTree
scriptFails name script = Terminal $ Specification name Failure script scriptFails name script = Terminal $ Specification name Failure script
mkContext :: ScriptContext -> Context
mkContext = Context . toBuiltinData
mkRedeemer ::
forall redeemer.
(PlutusTx.ToData redeemer) =>
redeemer ->
Redeemer
mkRedeemer = Redeemer . toBuiltinData
mkDatum ::
forall datum.
(PlutusTx.ToData datum) =>
datum ->
Datum
mkDatum = Datum . toBuiltinData
applyMintingPolicy' ::
(PlutusTx.ToData redeemer) =>
CompiledMintingPolicy redeemer ->
redeemer ->
ScriptContext ->
Script
applyMintingPolicy' policy redeemer scriptContext =
applyMintingPolicyScript
(mkContext scriptContext)
(getCompiledMintingPolicy policy)
(mkRedeemer redeemer)
applyValidator' ::
( PlutusTx.ToData datum
, PlutusTx.ToData redeemer
) =>
CompiledValidator datum redeemer ->
datum ->
redeemer ->
ScriptContext ->
Script
applyValidator' validator datum redeemer scriptContext =
applyValidator
(mkContext scriptContext)
(getCompiledValidator validator)
(mkDatum datum)
(mkRedeemer redeemer)
-- | Check that a policy script succeeds, given a name and arguments. -- | Check that a policy script succeeds, given a name and arguments.
policySucceedsWith :: policySucceedsWith ::
( PLift redeemer (PlutusTx.ToData redeemer) =>
, PlutusTx.ToData (PLifted redeemer)
) =>
String -> String ->
ClosedTerm PMintingPolicy -> CompiledMintingPolicy redeemer ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
policySucceedsWith tag policy redeemer scriptContext = policySucceedsWith tag =
scriptSucceeds tag $ scriptSucceeds tag .** applyMintingPolicy'
mustCompile
( policy
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
-- | Check that a policy script fails, given a name and arguments. -- | Check that a policy script fails, given a name and arguments.
policyFailsWith :: policyFailsWith ::
( PLift redeemer (PlutusTx.ToData redeemer) =>
, PlutusTx.ToData (PLifted redeemer)
) =>
String -> String ->
ClosedTerm PMintingPolicy -> CompiledMintingPolicy redeemer ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
policyFailsWith tag policy redeemer scriptContext = policyFailsWith tag =
scriptFails tag $ scriptFails tag .** applyMintingPolicy'
mustCompile
( policy
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
-- | Check that a validator script succeeds, given a name and arguments. -- | Check that a validator script succeeds, given a name and arguments.
validatorSucceedsWith :: validatorSucceedsWith ::
( PLift datum ( PlutusTx.ToData datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData redeemer
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) => ) =>
String -> String ->
ClosedTerm PValidator -> CompiledValidator datum redeemer ->
PLifted datum -> datum ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
validatorSucceedsWith tag validator datum redeemer scriptContext = validatorSucceedsWith tag =
scriptSucceeds tag $ scriptSucceeds tag .*** applyValidator'
mustCompile
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
-- | Check that a validator script fails, given a name and arguments. -- | Check that a validator script fails, given a name and arguments.
validatorFailsWith :: validatorFailsWith ::
( PLift datum ( PlutusTx.ToData datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData redeemer
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) => ) =>
String -> String ->
ClosedTerm PValidator -> CompiledValidator datum redeemer ->
PLifted datum -> datum ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
validatorFailsWith tag validator datum redeemer scriptContext = validatorFailsWith tag =
scriptFails tag $ scriptFails tag .*** applyValidator'
mustCompile
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
-- | Check that an effect succeeds, given a name and argument. -- | Check that an effect succeeds, given a name and argument.
effectSucceedsWith :: effectSucceedsWith ::
( PLift datum ( PlutusTx.ToData datum
, PlutusTx.ToData (PLifted datum)
) => ) =>
String -> String ->
ClosedTerm PValidator -> CompiledEffect datum ->
PLifted datum -> datum ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () effectSucceedsWith tag eff datum = validatorSucceedsWith tag (coerce eff) datum ()
-- | Check that an effect fails, given a name and argument. -- | Check that an effect fails, given a name and argument.
effectFailsWith :: effectFailsWith ::
( PLift datum ( PlutusTx.ToData datum
, PlutusTx.ToData (PLifted datum)
) => ) =>
String -> String ->
ClosedTerm PValidator -> CompiledEffect datum ->
PLifted datum -> datum ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
effectFailsWith tag eff datum = validatorFailsWith tag eff datum () effectFailsWith tag eff datum = validatorFailsWith tag (coerce eff) datum ()
-- | Test a validator, given the expectation as a boolean value.
testValidator :: testValidator ::
( PLift datum forall datum redeemer.
, PlutusTx.ToData (PLifted datum) (PlutusTx.ToData datum, PlutusTx.ToData redeemer) =>
, PLift redeemer -- | Is this test case expected to succeed?
, PlutusTx.ToData (PLifted redeemer)
) =>
-- | Should the validator pass?
Bool -> Bool ->
String -> String ->
ClosedTerm PValidator -> CompiledValidator datum redeemer ->
PLifted datum -> datum ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
testValidator isValid = testValidator isValid =
@ -276,14 +293,15 @@ testValidator isValid =
then validatorSucceedsWith then validatorSucceedsWith
else validatorFailsWith else validatorFailsWith
-- | Test a policy, given the expectation as a boolean value.
testPolicy :: testPolicy ::
( PLift redeemer forall redeemer.
, PlutusTx.ToData (PLifted redeemer) (PlutusTx.ToData redeemer) =>
) => -- | Is this test case expected to succeed?
Bool -> Bool ->
String -> String ->
ClosedTerm PMintingPolicy -> CompiledMintingPolicy redeemer ->
PLifted redeemer -> redeemer ->
ScriptContext -> ScriptContext ->
SpecificationTree SpecificationTree
testPolicy isValid = testPolicy isValid =