speed up test execution by precompiling scripts
x250 faster!
This commit is contained in:
Hongrui Fang
parent
91f7118ec3
commit
638dc2d0c6
18 changed files with 299 additions and 282 deletions
|
|
@ -7,7 +7,7 @@ Property model and tests for 'Governor' related functions
|
|||
-}
|
||||
module Property.Governor (props) where
|
||||
|
||||
import Agora.Governor (GovernorDatum (..), pisGovernorDatumValid)
|
||||
import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
|
||||
import Agora.Governor.Scripts (governorPolicy)
|
||||
import Agora.Proposal (
|
||||
ProposalId (ProposalId),
|
||||
|
|
@ -201,7 +201,7 @@ governorMintingProperty =
|
|||
opaqueToUnit = plam $ \_ -> pconstant ()
|
||||
|
||||
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 sc
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ import Agora.Effect.GovernorMutation (
|
|||
)
|
||||
import Agora.Governor (GovernorDatum (..))
|
||||
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Tagged (Tagged (..))
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
|
|
@ -24,7 +25,6 @@ import PlutusLedgerApi.V1 (
|
|||
Address,
|
||||
Datum (..),
|
||||
ToData (..),
|
||||
TokenName (..),
|
||||
TxInInfo (..),
|
||||
TxInfo (..),
|
||||
TxOut (..),
|
||||
|
|
@ -40,10 +40,11 @@ import PlutusLedgerApi.V1.Value qualified as Value (
|
|||
singleton,
|
||||
)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
authorityTokenSymbol,
|
||||
deterministicTracingConfing,
|
||||
govAssetClass,
|
||||
govValidatorAddress,
|
||||
governor,
|
||||
minAda,
|
||||
signer,
|
||||
)
|
||||
|
|
@ -51,7 +52,7 @@ import Test.Util (datumPair, toDatumHash)
|
|||
|
||||
-- | The effect validator instance.
|
||||
effectValidator :: Validator
|
||||
effectValidator = mkValidator def $ mutateGovernorValidator governor
|
||||
effectValidator = mkValidator deterministicTracingConfing $ mutateGovernorValidator agoraScripts
|
||||
|
||||
-- | The hash of the validator instance.
|
||||
effectValidatorHash :: ValidatorHash
|
||||
|
|
@ -65,17 +66,15 @@ effectValidatorAddress = scriptHashAddress effectValidatorHash
|
|||
atAssetClass :: AssetClass
|
||||
atAssetClass = assetClass authorityTokenSymbol tokenName
|
||||
where
|
||||
-- TODO: use 'validatorHashToTokenName'
|
||||
ValidatorHash bs = effectValidatorHash
|
||||
tokenName = TokenName bs
|
||||
tokenName = validatorHashToTokenName effectValidatorHash
|
||||
|
||||
-- | The mock reference of the governor state UTXO.
|
||||
govRef :: TxOutRef
|
||||
govRef = TxOutRef "614481d2159bfb72350222d61fce17e548e0fc00e5a1f841ff1837c431346ce7" 1
|
||||
govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
|
||||
|
||||
-- | The mock reference of the effect UTXO.
|
||||
effectRef :: TxOutRef
|
||||
effectRef = TxOutRef "c31164dc11835de7eb6187f67d0e1a19c1dfc0786a456923eef5043189cdb578" 1
|
||||
effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
|
||||
|
||||
-- | The input effect datum in 'mkEffectTransaction'.
|
||||
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
|
||||
|
|
@ -159,7 +158,7 @@ mkEffectTxInfo newGovDatum =
|
|||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
|
||||
, txInfoId = "4dae3806cc69615b721d52ed09b758f43f25a8f39b7934d6b28514caf71f5f7b"
|
||||
, txInfoId = "74c75505691e7baa981fa80e50b9b7e88dbe1eda67d4f062d89d203b"
|
||||
}
|
||||
|
||||
validNewGovernorDatum :: GovernorDatum
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ import Plutarch.Api.V1 (mkValidator, validatorHash)
|
|||
import PlutusLedgerApi.V1 (
|
||||
Address (Address),
|
||||
Credential (..),
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
CurrencySymbol,
|
||||
DatumHash (DatumHash),
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
|
|
@ -60,7 +60,7 @@ import Test.Util (scriptCredentials, userCredentials)
|
|||
|
||||
-- | A sample Currency Symbol.
|
||||
currSymbol :: CurrencySymbol
|
||||
currSymbol = CurrencySymbol "12312099"
|
||||
currSymbol = "9c04a69c7133e26061fe5a15adaf4f79cd51e47ef22a2e3c91a36f04"
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
|
|
|
|||
|
|
@ -19,16 +19,20 @@ module Sample.Governor.Initialize (
|
|||
mkTestCase,
|
||||
) where
|
||||
|
||||
import Agora.Bootstrap (agoraScripts)
|
||||
import Agora.Governor (Governor (..), GovernorDatum (..))
|
||||
import Agora.Governor.Scripts (
|
||||
governorPolicy,
|
||||
governorSTAssetClassFromGovernor,
|
||||
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
|
||||
import Agora.Proposal.Time (
|
||||
MaxTimeRangeWidth (MaxTimeRangeWidth),
|
||||
ProposalTimingConfig (ProposalTimingConfig),
|
||||
)
|
||||
import Agora.Scripts (
|
||||
AgoraScripts (compiledGovernorPolicy),
|
||||
governorSTAssetClass,
|
||||
governorSTSymbol,
|
||||
governorValidatorHash,
|
||||
)
|
||||
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
|
||||
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalTimingConfig (ProposalTimingConfig))
|
||||
import Data.Default (Default (..))
|
||||
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
|
||||
import Plutarch.Context (
|
||||
input,
|
||||
mint,
|
||||
|
|
@ -43,7 +47,6 @@ import Plutarch.Context (
|
|||
)
|
||||
import PlutusLedgerApi.V1 (
|
||||
CurrencySymbol,
|
||||
MintingPolicy,
|
||||
TxOutRef (TxOutRef),
|
||||
ValidatorHash,
|
||||
)
|
||||
|
|
@ -107,17 +110,17 @@ governor =
|
|||
{ gstOutRef = witnessRef
|
||||
}
|
||||
|
||||
scripts :: AgoraScripts
|
||||
scripts = agoraScripts Shared.deterministicTracingConfing governor
|
||||
|
||||
govAssetClass :: AssetClass
|
||||
govAssetClass = governorSTAssetClassFromGovernor governor
|
||||
govAssetClass = governorSTAssetClass scripts
|
||||
|
||||
govValidatorHash :: ValidatorHash
|
||||
govValidatorHash = governorValidatorHash governor
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy def (governorPolicy governor)
|
||||
govValidatorHash = governorValidatorHash scripts
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
govSymbol = governorSTSymbol scripts
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -271,6 +274,6 @@ mkTestCase name ps valid =
|
|||
testPolicy
|
||||
valid
|
||||
name
|
||||
(governorPolicy governor)
|
||||
scripts.compiledGovernorPolicy
|
||||
()
|
||||
(mkMinting mintGST ps govSymbol)
|
||||
|
|
|
|||
|
|
@ -18,8 +18,8 @@ module Sample.Governor.Mutate (
|
|||
|
||||
import Agora.Effect.NoOp (noOpValidator)
|
||||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Governor.Scripts (governorValidator)
|
||||
import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Default (def)
|
||||
import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash)
|
||||
|
|
@ -42,10 +42,10 @@ import PlutusLedgerApi.V1 (
|
|||
)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
authorityTokenSymbol,
|
||||
govAssetClass,
|
||||
govValidatorHash,
|
||||
governor,
|
||||
minAda,
|
||||
)
|
||||
import Test.Specification (SpecificationTree, testValidator)
|
||||
|
|
@ -219,7 +219,7 @@ mkTestCase name pb (Validity forGov) =
|
|||
testValidator
|
||||
forGov
|
||||
name
|
||||
(governorValidator governor)
|
||||
agoraScripts.compiledGovernorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
(mkSpending mutate pb governorRef)
|
||||
|
|
|
|||
|
|
@ -37,15 +37,11 @@ module Sample.Proposal.Advance (
|
|||
mkBadGovernorOutputDatumBundle,
|
||||
) where
|
||||
|
||||
import Agora.AuthorityToken (
|
||||
AuthorityToken (AuthorityToken),
|
||||
authorityTokenPolicy,
|
||||
)
|
||||
import Agora.Governor (
|
||||
Governor (..),
|
||||
GovernorDatum (..),
|
||||
GovernorRedeemer (MintGATs),
|
||||
)
|
||||
import Agora.Governor.Scripts (governorValidator)
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
ProposalId (ProposalId),
|
||||
|
|
@ -56,7 +52,6 @@ import Agora.Proposal (
|
|||
ResultTag (ResultTag),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Proposal.Scripts (proposalValidator)
|
||||
import Agora.Proposal.Time (
|
||||
ProposalStartingTime (ProposalStartingTime),
|
||||
ProposalTimingConfig (
|
||||
|
|
@ -66,12 +61,11 @@ import Agora.Proposal.Time (
|
|||
votingTime
|
||||
),
|
||||
)
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (WitnessStake),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Control.Monad.State (execState, modify, when)
|
||||
import Data.Default (def)
|
||||
|
|
@ -107,18 +101,18 @@ import Sample.Proposal.Shared (
|
|||
stakeTxRef,
|
||||
)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
authorityTokenSymbol,
|
||||
govAssetClass,
|
||||
govValidatorHash,
|
||||
governor,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
signer,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
|
|
@ -394,7 +388,7 @@ mkStakeBuilder ps =
|
|||
minAda
|
||||
<> Value.assetClassValue stakeAssetClass 1
|
||||
<> Value.assetClassValue
|
||||
(untag stake.gtClassRef)
|
||||
(untag governor.gtClassRef)
|
||||
ps.perStakeGTs
|
||||
perStake idx i o =
|
||||
let withSig =
|
||||
|
|
@ -565,7 +559,7 @@ mkTestTree name pb val =
|
|||
testValidator
|
||||
val.forProposalValidator
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
agoraScripts.compiledProposalValidator
|
||||
proposalInputDatum
|
||||
proposalRedeemer
|
||||
(spend proposalRef)
|
||||
|
|
@ -576,7 +570,7 @@ mkTestTree name pb val =
|
|||
testValidator
|
||||
val.forStakeValidator
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(getStakeInputDatumAt pb.stakeParameters idx)
|
||||
stakeRedeemer
|
||||
( spend (mkStakeRef idx)
|
||||
|
|
@ -586,7 +580,7 @@ mkTestTree name pb val =
|
|||
testValidator
|
||||
(fromJust val.forGovernorValidator)
|
||||
"governor"
|
||||
(governorValidator Shared.governor)
|
||||
agoraScripts.compiledGovernorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
(spend governorRef)
|
||||
|
|
@ -596,7 +590,7 @@ mkTestTree name pb val =
|
|||
testPolicy
|
||||
(fromJust val.forAuthorityTokenPolicy)
|
||||
"authority"
|
||||
(authorityTokenPolicy $ AuthorityToken Shared.govAssetClass)
|
||||
agoraScripts.compiledAuthorityTokenPolicy
|
||||
authorityTokenRedeemer
|
||||
(mint authorityTokenSymbol)
|
||||
<$ (pb.authorityTokenParameters)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ module Sample.Proposal.Cosign (
|
|||
mkTestTree,
|
||||
) where
|
||||
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
ProposalId (ProposalId),
|
||||
|
|
@ -22,19 +23,17 @@ import Agora.Proposal (
|
|||
ResultTag (ResultTag),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Proposal.Scripts (proposalValidator)
|
||||
import Agora.Proposal.Time (
|
||||
ProposalStartingTime (ProposalStartingTime),
|
||||
ProposalTimingConfig (draftTime),
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (StakeDatum, owner),
|
||||
StakeRedeemer (WitnessStake),
|
||||
stakedAmount,
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default (def)
|
||||
import Data.List (sort)
|
||||
|
|
@ -61,15 +60,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
governor,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
signer,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
|
|
@ -149,7 +148,7 @@ cosign ps = builder
|
|||
sortValue $
|
||||
minAda
|
||||
<> Value.assetClassValue
|
||||
(untag stake.gtClassRef)
|
||||
(untag governor.gtClassRef)
|
||||
(untag perStakedGTs)
|
||||
<> sst
|
||||
|
||||
|
|
@ -322,7 +321,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
|
|||
in testValidator
|
||||
isValid
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
agoraScripts.compiledProposalValidator
|
||||
proposalInputDatum
|
||||
(mkProposalRedeemer ps)
|
||||
(spend proposalRef)
|
||||
|
|
@ -334,7 +333,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
|
|||
in testValidator
|
||||
isValid
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
stakeInputDatum
|
||||
stakeRedeemer
|
||||
(spend $ mkStakeRef idx)
|
||||
|
|
|
|||
|
|
@ -20,27 +20,24 @@ module Sample.Proposal.Create (
|
|||
) where
|
||||
|
||||
import Agora.Governor (
|
||||
Governor (..),
|
||||
GovernorDatum (..),
|
||||
GovernorRedeemer (CreateProposal),
|
||||
)
|
||||
import Agora.Governor.Scripts (governorValidator)
|
||||
import Agora.Proposal (
|
||||
Proposal (governorSTAssetClass),
|
||||
ProposalDatum (..),
|
||||
ProposalId (ProposalId),
|
||||
ProposalStatus (..),
|
||||
ResultTag (ResultTag),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Proposal.Scripts (proposalPolicy)
|
||||
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..))
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
ProposalLock (..),
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default (Default (def))
|
||||
import Data.Tagged (Tagged, untag)
|
||||
|
|
@ -69,19 +66,19 @@ import PlutusLedgerApi.V1.Value qualified as Value
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Sample.Proposal.Shared (stakeTxRef)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
govAssetClass,
|
||||
govValidatorHash,
|
||||
governor,
|
||||
minAda,
|
||||
proposal,
|
||||
proposalPolicySymbol,
|
||||
proposalStartingTimeFromTimeRange,
|
||||
proposalValidatorHash,
|
||||
signer,
|
||||
signer2,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
|
||||
import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue)
|
||||
|
||||
|
|
@ -270,7 +267,7 @@ createProposal ps = builder
|
|||
where
|
||||
pst = Value.singleton proposalPolicySymbol "" 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 $
|
||||
sst
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakedGTs)
|
||||
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
|
||||
<> minAda
|
||||
proposalValue = sortValue $ pst <> minAda
|
||||
|
||||
|
|
@ -438,7 +435,7 @@ mkTestTree
|
|||
testPolicy
|
||||
validForProposalPolicy
|
||||
"proposal"
|
||||
(proposalPolicy Shared.proposal.governorSTAssetClass)
|
||||
agoraScripts.compiledProposalPolicy
|
||||
proposalPolicyRedeemer
|
||||
(mint proposalPolicySymbol)
|
||||
|
||||
|
|
@ -446,15 +443,16 @@ mkTestTree
|
|||
testValidator
|
||||
validForGovernorValidator
|
||||
"governor"
|
||||
(governorValidator Shared.governor)
|
||||
agoraScripts.compiledGovernorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
(spend governorRef)
|
||||
|
||||
stakeTest =
|
||||
testValidator
|
||||
validForStakeValidator
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(mkStakeInputDatum ps)
|
||||
stakeRedeemer
|
||||
(spend stakeRef)
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ module Sample.Proposal.UnlockStake (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
ProposalId (..),
|
||||
|
|
@ -33,10 +34,9 @@ import Agora.Proposal (
|
|||
ProposalVotes (..),
|
||||
ResultTag (..),
|
||||
)
|
||||
import Agora.Proposal.Scripts (proposalValidator)
|
||||
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
|
||||
import Agora.Stake (ProposalLock (..), Stake (..), StakeDatum (..), StakeRedeemer (RetractVotes))
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Tagged (Tagged (..), untag)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -59,15 +59,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Sample.Proposal.Shared (stakeTxRef)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
governor,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
signer,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Specification (SpecificationTree, group, testValidator)
|
||||
import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
|
||||
|
||||
|
|
@ -277,7 +277,7 @@ unlockStake ps =
|
|||
sortValue $
|
||||
mconcat
|
||||
[ Value.assetClassValue
|
||||
(untag stake.gtClassRef)
|
||||
(untag governor.gtClassRef)
|
||||
(untag defStakedGTs)
|
||||
, sst
|
||||
, minAda
|
||||
|
|
@ -532,7 +532,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
|
|||
testValidator
|
||||
(not ps.alterOutputStake)
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(mkStakeInputDatum ps)
|
||||
stakeRedeemer
|
||||
(spend stakeRef)
|
||||
|
|
@ -544,7 +544,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
|
|||
in testValidator
|
||||
isValid
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
agoraScripts.compiledProposalValidator
|
||||
(mkProposalInputDatum ps pid)
|
||||
proposalRedeemer
|
||||
(spend ref)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ module Sample.Proposal.Vote (
|
|||
validVoteAsDelegateParameters,
|
||||
) where
|
||||
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
ProposalId (ProposalId),
|
||||
|
|
@ -19,18 +20,16 @@ import Agora.Proposal (
|
|||
ProposalVotes (ProposalVotes),
|
||||
ResultTag (ResultTag),
|
||||
)
|
||||
import Agora.Proposal.Scripts (proposalValidator)
|
||||
import Agora.Proposal.Time (
|
||||
ProposalStartingTime (ProposalStartingTime),
|
||||
ProposalTimingConfig (draftTime, votingTime),
|
||||
)
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
ProposalLock (..),
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Default (Default (def))
|
||||
import Data.Tagged (Tagged (Tagged), untag)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -52,15 +51,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
governor,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
signer,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
|
|
@ -205,7 +204,7 @@ vote params =
|
|||
stakeValue =
|
||||
sortValue $
|
||||
sst
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
|
||||
<> Value.assetClassValue (untag governor.gtClassRef) params.voteCount
|
||||
<> minAda
|
||||
|
||||
signer =
|
||||
|
|
@ -278,7 +277,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
|
|||
testValidator
|
||||
isValid
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
agoraScripts.compiledProposalValidator
|
||||
proposalInputDatum
|
||||
(mkProposalRedeemer ps)
|
||||
(spend proposalRef)
|
||||
|
|
@ -287,7 +286,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
|
|||
let stakeInputDatum = mkStakeInputDatum ps
|
||||
in validatorSucceedsWith
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
stakeInputDatum
|
||||
stakeRedeemer
|
||||
(spend stakeRef)
|
||||
|
|
|
|||
|
|
@ -12,11 +12,15 @@ module Sample.Shared (
|
|||
signer,
|
||||
signer2,
|
||||
minAda,
|
||||
deterministicTracingConfing,
|
||||
mkEffect,
|
||||
|
||||
-- * Agora Scripts
|
||||
agoraScripts,
|
||||
|
||||
-- * Components
|
||||
|
||||
-- ** Stake
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
stakeAddress,
|
||||
|
|
@ -33,14 +37,12 @@ module Sample.Shared (
|
|||
gstUTXORef,
|
||||
|
||||
-- ** Proposal
|
||||
proposal,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
proposalValidatorAddress,
|
||||
proposalStartingTimeFromTimeRange,
|
||||
|
||||
-- ** Authority
|
||||
authorityToken,
|
||||
authorityTokenSymbol,
|
||||
|
||||
-- ** Treasury
|
||||
|
|
@ -53,38 +55,29 @@ module Sample.Shared (
|
|||
wrongEffHash,
|
||||
) where
|
||||
|
||||
import Agora.AuthorityToken (AuthorityToken)
|
||||
import Agora.Bootstrap qualified as Bootstrap
|
||||
import Agora.Effect.NoOp (noOpValidator)
|
||||
import Agora.Governor (Governor (Governor))
|
||||
import Agora.Governor.Scripts (
|
||||
authorityTokenFromGovernor,
|
||||
authorityTokenSymbolFromGovernor,
|
||||
governorPolicy,
|
||||
governorSTAssetClassFromGovernor,
|
||||
governorValidator,
|
||||
governorValidatorHash,
|
||||
proposalFromGovernor,
|
||||
proposalSTSymbolFromGovernor,
|
||||
proposalValidatorHashFromGovernor,
|
||||
stakeFromGovernor,
|
||||
stakeSTAssetClassFromGovernor,
|
||||
stakeSTSymbolFromGovernor,
|
||||
stakeValidatorHashFromGovernor,
|
||||
)
|
||||
import Agora.Proposal (Proposal (..), ProposalThresholds (..))
|
||||
import Agora.Proposal (ProposalThresholds (..))
|
||||
import Agora.Proposal.Time (
|
||||
MaxTimeRangeWidth (..),
|
||||
ProposalStartingTime (ProposalStartingTime),
|
||||
ProposalTimingConfig (..),
|
||||
)
|
||||
import Agora.Stake (Stake (..))
|
||||
import Agora.Scripts qualified as Scripts
|
||||
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.Tagged (Tagged (..))
|
||||
import Plutarch (Config (..), TracingMode (DetTracing))
|
||||
import Plutarch.Api.V1 (
|
||||
PValidator,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
|
|
@ -110,24 +103,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
|
|||
assetClass,
|
||||
singleton,
|
||||
)
|
||||
import PlutusTx qualified
|
||||
|
||||
stake :: Stake
|
||||
stake = stakeFromGovernor governor
|
||||
|
||||
stakeSymbol :: CurrencySymbol
|
||||
stakeSymbol = stakeSTSymbolFromGovernor governor
|
||||
|
||||
stakeAssetClass :: AssetClass
|
||||
stakeAssetClass = stakeSTAssetClassFromGovernor governor
|
||||
|
||||
stakeValidatorHash :: ValidatorHash
|
||||
stakeValidatorHash = stakeValidatorHashFromGovernor governor
|
||||
|
||||
stakeAddress :: Address
|
||||
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
|
||||
gstUTXORef :: TxOutRef
|
||||
gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
|
||||
-- Plutarch compiler configauration.
|
||||
-- TODO: add the ability to change this value. Maybe wrap everything in a
|
||||
-- Reader monad?
|
||||
deterministicTracingConfing :: Config
|
||||
deterministicTracingConfing = Config DetTracing
|
||||
|
||||
governor :: Governor
|
||||
governor = Governor oref gt mc
|
||||
|
|
@ -140,29 +122,44 @@ governor = Governor oref gt mc
|
|||
"LQ"
|
||||
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 = mkMintingPolicy def (governorPolicy governor)
|
||||
govPolicy = getCompiledMintingPolicy $ agoraScripts.compiledGovernorPolicy
|
||||
|
||||
govValidator :: Validator
|
||||
govValidator = mkValidator def (governorValidator governor)
|
||||
govValidator = getCompiledValidator $ agoraScripts.compiledGovernorValidator
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
||||
govAssetClass :: AssetClass
|
||||
govAssetClass = governorSTAssetClassFromGovernor governor
|
||||
govAssetClass = Scripts.governorSTAssetClass agoraScripts
|
||||
|
||||
govValidatorHash :: ValidatorHash
|
||||
govValidatorHash = governorValidatorHash governor
|
||||
govValidatorHash = Scripts.governorValidatorHash agoraScripts
|
||||
|
||||
govValidatorAddress :: Address
|
||||
govValidatorAddress = scriptHashAddress govValidatorHash
|
||||
|
||||
proposal :: Proposal
|
||||
proposal = proposalFromGovernor governor
|
||||
|
||||
proposalPolicySymbol :: CurrencySymbol
|
||||
proposalPolicySymbol = proposalSTSymbolFromGovernor governor
|
||||
proposalPolicySymbol = Scripts.proposalSTSymbol agoraScripts
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
|
|
@ -173,7 +170,7 @@ signer2 :: PubKeyHash
|
|||
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
|
||||
|
||||
proposalValidatorHash :: ValidatorHash
|
||||
proposalValidatorHash = proposalValidatorHashFromGovernor governor
|
||||
proposalValidatorHash = Scripts.proposalValidatoHash agoraScripts
|
||||
|
||||
proposalValidatorAddress :: Address
|
||||
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
|
||||
|
|
@ -189,11 +186,8 @@ instance Default ProposalThresholds where
|
|||
, vote = Tagged 100
|
||||
}
|
||||
|
||||
authorityToken :: AuthorityToken
|
||||
authorityToken = authorityTokenFromGovernor governor
|
||||
|
||||
authorityTokenSymbol :: CurrencySymbol
|
||||
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
|
||||
authorityTokenSymbol = Scripts.authorityTokenSymbol agoraScripts
|
||||
|
||||
{- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
|
||||
For testing purpose only.
|
||||
|
|
@ -222,6 +216,9 @@ proposalStartingTimeFromTimeRange
|
|||
ProposalStartingTime $ (l + u) `div` 2
|
||||
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
|
||||
|
|
|
|||
|
|
@ -6,10 +6,8 @@ Description: Sample based testing for Stake utxos
|
|||
This module tests primarily the happy path for Stake creation
|
||||
-}
|
||||
module Sample.Stake (
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeSymbol,
|
||||
validatorHashTN,
|
||||
signer,
|
||||
|
||||
-- * Script contexts
|
||||
|
|
@ -20,15 +18,12 @@ module Sample.Stake (
|
|||
DepositWithdrawExample (..),
|
||||
) where
|
||||
|
||||
import Agora.Governor (Governor (gtClassRef))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (StakeDatum, stakedAmount),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Default (def)
|
||||
import Data.Tagged (Tagged, untag)
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import Plutarch.Context (
|
||||
MintingBuilder,
|
||||
SpendingBuilder,
|
||||
|
|
@ -51,9 +46,7 @@ import PlutusLedgerApi.V1 (
|
|||
ScriptContext (..),
|
||||
ScriptPurpose (Minting),
|
||||
ToData (toBuiltinData),
|
||||
TokenName (TokenName),
|
||||
TxInfo (txInfoData, txInfoSignatories),
|
||||
ValidatorHash (ValidatorHash),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (
|
||||
|
|
@ -61,19 +54,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
|
|||
singleton,
|
||||
)
|
||||
import Sample.Shared (
|
||||
governor,
|
||||
signer,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeSymbol,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
|
||||
-- | '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
|
||||
import Test.Util (sortValue)
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
stakeCreation :: ScriptContext
|
||||
|
|
@ -151,14 +138,22 @@ stakeDepositWithdraw config =
|
|||
, input $
|
||||
mconcat
|
||||
[ 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
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
mconcat
|
||||
[ 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
|
||||
]
|
||||
, withSpendingOutRef stakeRef
|
||||
|
|
|
|||
|
|
@ -19,12 +19,12 @@ module Sample.Stake.SetDelegate (
|
|||
delegateToOwnerParameters,
|
||||
) where
|
||||
|
||||
import Agora.Governor (Governor (gtClassRef))
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
Stake (gtClassRef),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (ClearDelegate, DelegateTo),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Tagged (untag)
|
||||
import Plutarch.Context (
|
||||
SpendingBuilder,
|
||||
|
|
@ -46,10 +46,11 @@ import PlutusLedgerApi.V1 (
|
|||
)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (
|
||||
agoraScripts,
|
||||
governor,
|
||||
minAda,
|
||||
signer,
|
||||
signer2,
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
|
|
@ -118,7 +119,7 @@ setDelegate ps = buildSpendingUnsafe builder
|
|||
mconcat
|
||||
[ st
|
||||
, Value.assetClassValue
|
||||
(untag stake.gtClassRef)
|
||||
(untag governor.gtClassRef)
|
||||
(untag stakeInput.stakedAmount)
|
||||
, minAda
|
||||
]
|
||||
|
|
@ -154,7 +155,7 @@ mkTestCase name ps valid =
|
|||
testValidator
|
||||
valid
|
||||
name
|
||||
(stakeValidator stake)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(mkStakeInputDatum ps)
|
||||
(mkStakeRedeemer ps)
|
||||
(setDelegate ps)
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@ module Spec.Effect.GovernorMutation (specs) where
|
|||
|
||||
import Agora.Effect.GovernorMutation (mutateGovernorValidator)
|
||||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Governor.Scripts (governorValidator)
|
||||
import Agora.Proposal (ProposalId (..))
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Data.Default.Class (Default (def))
|
||||
import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
|
||||
import Sample.Effect.GovernorMutation (
|
||||
|
|
@ -14,7 +14,7 @@ import Sample.Effect.GovernorMutation (
|
|||
mkEffectTxInfo,
|
||||
validNewGovernorDatum,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Sample.Shared (agoraScripts, mkEffect)
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
effectFailsWith,
|
||||
|
|
@ -32,7 +32,7 @@ specs =
|
|||
"valid new governor datum"
|
||||
[ validatorSucceedsWith
|
||||
"governor validator should pass"
|
||||
(governorValidator Shared.governor)
|
||||
agoraScripts.compiledGovernorValidator
|
||||
( GovernorDatum
|
||||
def
|
||||
(ProposalId 0)
|
||||
|
|
@ -47,7 +47,7 @@ specs =
|
|||
)
|
||||
, effectSucceedsWith
|
||||
"effect validator should pass"
|
||||
(mutateGovernorValidator Shared.governor)
|
||||
(mkEffect $ mutateGovernorValidator agoraScripts)
|
||||
(mkEffectDatum validNewGovernorDatum)
|
||||
(ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
|
||||
]
|
||||
|
|
@ -55,7 +55,7 @@ specs =
|
|||
"invalid new governor datum"
|
||||
[ validatorFailsWith
|
||||
"governor validator should fail"
|
||||
(governorValidator Shared.governor)
|
||||
agoraScripts.compiledGovernorValidator
|
||||
( GovernorDatum
|
||||
def
|
||||
(ProposalId 0)
|
||||
|
|
@ -70,7 +70,7 @@ specs =
|
|||
)
|
||||
, effectFailsWith
|
||||
"effect validator should fail"
|
||||
(mutateGovernorValidator Shared.governor)
|
||||
(mkEffect $ mutateGovernorValidator agoraScripts)
|
||||
(mkEffectDatum validNewGovernorDatum)
|
||||
(ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
|
||||
]
|
||||
|
|
|
|||
|
|
@ -25,12 +25,14 @@ import Sample.Effect.TreasuryWithdrawal (
|
|||
treasuries,
|
||||
users,
|
||||
)
|
||||
import Sample.Shared (mkEffect)
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
effectFailsWith,
|
||||
effectSucceedsWith,
|
||||
group,
|
||||
)
|
||||
import Test.Util (sortValue)
|
||||
|
||||
specs :: [SpecificationTree]
|
||||
specs =
|
||||
|
|
@ -38,7 +40,7 @@ specs =
|
|||
"effect"
|
||||
[ effectSucceedsWith
|
||||
"Simple"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum1
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -50,7 +52,7 @@ specs =
|
|||
)
|
||||
, effectSucceedsWith
|
||||
"Simple with multiple treasuries "
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum1
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -67,7 +69,7 @@ specs =
|
|||
)
|
||||
, effectSucceedsWith
|
||||
"Mixed Assets"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -82,7 +84,7 @@ specs =
|
|||
)
|
||||
, effectFailsWith
|
||||
"Pay to uknown 3rd party"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -98,7 +100,7 @@ specs =
|
|||
)
|
||||
, effectFailsWith
|
||||
"Missing receiver"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -113,7 +115,7 @@ specs =
|
|||
)
|
||||
, effectFailsWith
|
||||
"Unauthorized treasury"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum3
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -125,7 +127,7 @@ specs =
|
|||
)
|
||||
, effectFailsWith
|
||||
"Prevent transactions besides the withdrawal"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
(mkEffect $ treasuryWithdrawalValidator currSymbol)
|
||||
datum3
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
|
|
@ -141,8 +143,14 @@ specs =
|
|||
]
|
||||
]
|
||||
where
|
||||
asset1 = Value.singleton "abbc12" "OrangeBottle"
|
||||
asset2 = Value.singleton "abbc12" "19721121"
|
||||
asset1 =
|
||||
Value.singleton
|
||||
"0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
|
||||
"OrangeBottle"
|
||||
asset2 =
|
||||
Value.singleton
|
||||
"7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
|
||||
"19721121"
|
||||
datum1 =
|
||||
TreasuryWithdrawalDatum
|
||||
[ (head users, asset1 1)
|
||||
|
|
@ -155,8 +163,8 @@ specs =
|
|||
]
|
||||
datum2 =
|
||||
TreasuryWithdrawalDatum
|
||||
[ (head users, asset2 5 <> asset1 4)
|
||||
, (users !! 1, asset2 1 <> asset1 2)
|
||||
[ (head users, sortValue $ asset2 5 <> asset1 4)
|
||||
, (users !! 1, sortValue $ asset2 1 <> asset1 2)
|
||||
, (users !! 2, asset1 1)
|
||||
]
|
||||
[ head treasuries
|
||||
|
|
|
|||
|
|
@ -9,14 +9,14 @@ Tests for Stake policy and validator
|
|||
-}
|
||||
module Spec.Stake (specs) where
|
||||
|
||||
import Agora.Scripts (AgoraScripts (..))
|
||||
import Agora.Stake (
|
||||
Stake (..),
|
||||
StakeDatum (StakeDatum),
|
||||
StakeRedeemer (DepositWithdraw),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Data.Bool (Bool (..))
|
||||
import Data.Maybe (Maybe (..))
|
||||
import Sample.Shared (agoraScripts)
|
||||
import Sample.Stake (
|
||||
DepositWithdrawExample (
|
||||
DepositWithdrawExample,
|
||||
|
|
@ -26,7 +26,6 @@ import Sample.Stake (
|
|||
signer,
|
||||
)
|
||||
import Sample.Stake qualified as Stake (
|
||||
stake,
|
||||
stakeCreation,
|
||||
stakeCreationUnsigned,
|
||||
stakeCreationWrongDatum,
|
||||
|
|
@ -41,7 +40,6 @@ import Test.Specification (
|
|||
validatorFailsWith,
|
||||
validatorSucceedsWith,
|
||||
)
|
||||
import Test.Util (toDatum)
|
||||
import Prelude (Num (negate), ($))
|
||||
|
||||
-- | The SpecificationTree exported by this module.
|
||||
|
|
@ -51,17 +49,17 @@ specs =
|
|||
"policy"
|
||||
[ policySucceedsWith
|
||||
"stakeCreation"
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
agoraScripts.compiledStakePolicy
|
||||
()
|
||||
Stake.stakeCreation
|
||||
, policyFailsWith
|
||||
"stakeCreationWrongDatum"
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
agoraScripts.compiledStakePolicy
|
||||
()
|
||||
Stake.stakeCreationWrongDatum
|
||||
, policyFailsWith
|
||||
"stakeCreationUnsigned"
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
agoraScripts.compiledStakePolicy
|
||||
()
|
||||
Stake.stakeCreationUnsigned
|
||||
]
|
||||
|
|
@ -69,21 +67,21 @@ specs =
|
|||
"validator"
|
||||
[ validatorSucceedsWith
|
||||
"stakeDepositWithdraw deposit"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer Nothing [])
|
||||
(toDatum $ DepositWithdraw 100_000)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(StakeDatum 100_000 signer Nothing [])
|
||||
(DepositWithdraw 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
|
||||
, validatorSucceedsWith
|
||||
"stakeDepositWithdraw withdraw"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer Nothing [])
|
||||
(toDatum $ DepositWithdraw $ negate 100_000)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(StakeDatum 100_000 signer Nothing [])
|
||||
(DepositWithdraw $ negate 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
|
||||
, validatorFailsWith
|
||||
"stakeDepositWithdraw negative GT"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer Nothing [])
|
||||
(toDatum $ DepositWithdraw 1_000_000)
|
||||
agoraScripts.compiledStakeValidator
|
||||
(StakeDatum 100_000 signer Nothing [])
|
||||
(DepositWithdraw 1_000_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
|
||||
, group
|
||||
"set delegate"
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@ import Agora.Treasury (
|
|||
TreasuryRedeemer (SpendTreasuryGAT),
|
||||
treasuryValidator,
|
||||
)
|
||||
import Agora.Utils (CompiledValidator (CompiledValidator))
|
||||
import Plutarch.Api.V1 (mkValidator)
|
||||
import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey))
|
||||
import PlutusLedgerApi.V1.Contexts (
|
||||
ScriptContext (scriptContextPurpose, scriptContextTxInfo),
|
||||
|
|
@ -35,7 +37,7 @@ import PlutusLedgerApi.V1.Credential (
|
|||
StakingCredential (StakingHash),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (singleton)
|
||||
import Sample.Shared (trCredential)
|
||||
import Sample.Shared (deterministicTracingConfing, trCredential)
|
||||
import Sample.Treasury (
|
||||
gatCs,
|
||||
gatTn,
|
||||
|
|
@ -51,6 +53,12 @@ import Test.Specification (
|
|||
validatorSucceedsWith,
|
||||
)
|
||||
|
||||
compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
|
||||
compiledTreasuryValidator =
|
||||
CompiledValidator $
|
||||
mkValidator deterministicTracingConfing $
|
||||
treasuryValidator gatCs
|
||||
|
||||
specs :: [SpecificationTree]
|
||||
specs =
|
||||
[ group
|
||||
|
|
@ -59,7 +67,7 @@ specs =
|
|||
"Positive"
|
||||
[ validatorSucceedsWith
|
||||
"Allows for effect changes"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
validCtx
|
||||
|
|
@ -70,7 +78,7 @@ specs =
|
|||
"Fails with ScriptPurpose not Minting"
|
||||
[ validatorFailsWith
|
||||
"Spending"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
validCtx
|
||||
|
|
@ -78,7 +86,7 @@ specs =
|
|||
}
|
||||
, validatorFailsWith
|
||||
"Rewarding"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
validCtx
|
||||
|
|
@ -88,7 +96,7 @@ specs =
|
|||
}
|
||||
, validatorFailsWith
|
||||
"Certifying"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
validCtx
|
||||
|
|
@ -100,7 +108,7 @@ specs =
|
|||
]
|
||||
, validatorFailsWith -- TODO: Use QuickCheck.
|
||||
"Fails when multiple GATs burned"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
validCtx
|
||||
|
|
@ -115,13 +123,13 @@ specs =
|
|||
}
|
||||
, validatorFailsWith
|
||||
"Fails when GAT token name is not script address"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
trCtxGATNameNotAddress
|
||||
, validatorFailsWith
|
||||
"Fails with wallet as input"
|
||||
(treasuryValidator gatCs)
|
||||
compiledTreasuryValidator
|
||||
()
|
||||
SpendTreasuryGAT
|
||||
( let txInfo = validCtx.scriptContextTxInfo
|
||||
|
|
|
|||
|
|
@ -49,12 +49,18 @@ module Test.Specification (
|
|||
toTestTree,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Agora.Utils (CompiledEffect (..), CompiledMintingPolicy (..), CompiledValidator (..))
|
||||
import Control.Composition ((.**), (.***))
|
||||
import Data.Coerce (coerce)
|
||||
import Plutarch.Evaluate (evalScript)
|
||||
import Plutarch.Extra.Compile (mustCompile)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1 (Script, ScriptContext)
|
||||
import PlutusLedgerApi.V1 (
|
||||
Datum (..),
|
||||
Redeemer (Redeemer),
|
||||
Script,
|
||||
ScriptContext,
|
||||
ToData (toBuiltinData),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Scripts (Context (..), applyMintingPolicyScript, applyValidator)
|
||||
import PlutusTx.IsData qualified as PlutusTx (ToData)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit (assertFailure, testCase)
|
||||
|
|
@ -153,122 +159,133 @@ scriptSucceeds name script = Terminal $ Specification name Success script
|
|||
scriptFails :: String -> Script -> SpecificationTree
|
||||
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.
|
||||
policySucceedsWith ::
|
||||
( PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
(PlutusTx.ToData redeemer) =>
|
||||
String ->
|
||||
ClosedTerm PMintingPolicy ->
|
||||
PLifted redeemer ->
|
||||
CompiledMintingPolicy redeemer ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
policySucceedsWith tag policy redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
mustCompile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
policySucceedsWith tag =
|
||||
scriptSucceeds tag .** applyMintingPolicy'
|
||||
|
||||
-- | Check that a policy script fails, given a name and arguments.
|
||||
policyFailsWith ::
|
||||
( PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
(PlutusTx.ToData redeemer) =>
|
||||
String ->
|
||||
ClosedTerm PMintingPolicy ->
|
||||
PLifted redeemer ->
|
||||
CompiledMintingPolicy redeemer ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
policyFailsWith tag policy redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
mustCompile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
policyFailsWith tag =
|
||||
scriptFails tag .** applyMintingPolicy'
|
||||
|
||||
-- | Check that a validator script succeeds, given a name and arguments.
|
||||
validatorSucceedsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
, PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
( PlutusTx.ToData datum
|
||||
, PlutusTx.ToData redeemer
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
PLifted redeemer ->
|
||||
CompiledValidator datum redeemer ->
|
||||
datum ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
validatorSucceedsWith tag validator datum redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
mustCompile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
validatorSucceedsWith tag =
|
||||
scriptSucceeds tag .*** applyValidator'
|
||||
|
||||
-- | Check that a validator script fails, given a name and arguments.
|
||||
validatorFailsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
, PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
( PlutusTx.ToData datum
|
||||
, PlutusTx.ToData redeemer
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
PLifted redeemer ->
|
||||
CompiledValidator datum redeemer ->
|
||||
datum ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
validatorFailsWith tag validator datum redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
mustCompile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
validatorFailsWith tag =
|
||||
scriptFails tag .*** applyValidator'
|
||||
|
||||
-- | Check that an effect succeeds, given a name and argument.
|
||||
effectSucceedsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
( PlutusTx.ToData datum
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
CompiledEffect datum ->
|
||||
datum ->
|
||||
ScriptContext ->
|
||||
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.
|
||||
effectFailsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
( PlutusTx.ToData datum
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
CompiledEffect datum ->
|
||||
datum ->
|
||||
ScriptContext ->
|
||||
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 ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
, PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
-- | Should the validator pass?
|
||||
forall datum redeemer.
|
||||
(PlutusTx.ToData datum, PlutusTx.ToData redeemer) =>
|
||||
-- | Is this test case expected to succeed?
|
||||
Bool ->
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
PLifted redeemer ->
|
||||
CompiledValidator datum redeemer ->
|
||||
datum ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
testValidator isValid =
|
||||
|
|
@ -276,14 +293,15 @@ testValidator isValid =
|
|||
then validatorSucceedsWith
|
||||
else validatorFailsWith
|
||||
|
||||
-- | Test a policy, given the expectation as a boolean value.
|
||||
testPolicy ::
|
||||
( PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
forall redeemer.
|
||||
(PlutusTx.ToData redeemer) =>
|
||||
-- | Is this test case expected to succeed?
|
||||
Bool ->
|
||||
String ->
|
||||
ClosedTerm PMintingPolicy ->
|
||||
PLifted redeemer ->
|
||||
CompiledMintingPolicy redeemer ->
|
||||
redeemer ->
|
||||
ScriptContext ->
|
||||
SpecificationTree
|
||||
testPolicy isValid =
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue