merge #74; add sample and spec of the governor
This commit is contained in:
fanghr
parent
4a74fcc44c
commit
9f116dd2cf
16 changed files with 81 additions and 46 deletions
|
|
@ -13,6 +13,7 @@ import Spec.Model.MultiSig qualified as MultiSig
|
|||
import Spec.Proposal qualified as Proposal
|
||||
import Spec.Stake qualified as Stake
|
||||
import Spec.Treasury qualified as Treasury
|
||||
import Spec.Utils qualified as Utils
|
||||
|
||||
-- | The Agora test suite.
|
||||
main :: IO ()
|
||||
|
|
@ -44,6 +45,9 @@ main =
|
|||
, testGroup
|
||||
"Governor tests"
|
||||
Governor.tests
|
||||
, testGroup
|
||||
"Utility functions tests"
|
||||
Utils.tests
|
||||
, testGroup
|
||||
"Multisig tests"
|
||||
[ testGroup
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ import Plutus.V1.Ledger.Api (
|
|||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Util (scriptFails, scriptSucceeds)
|
||||
import Test.Util (scriptFails, scriptSucceeds)
|
||||
|
||||
currencySymbol :: CurrencySymbol
|
||||
currencySymbol = "deadbeef"
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import Agora.Effect.TreasuryWithdrawal (
|
|||
treasuryWithdrawalValidator,
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import Spec.Sample.Effect.TreasuryWithdrawal (
|
||||
import Sample.Effect.TreasuryWithdrawal (
|
||||
buildReceiversOutputFromDatum,
|
||||
buildScriptContext,
|
||||
currSymbol,
|
||||
|
|
@ -25,8 +25,8 @@ import Spec.Sample.Effect.TreasuryWithdrawal (
|
|||
treasuries,
|
||||
users,
|
||||
)
|
||||
import Spec.Util (effectFailsWith, effectSucceedsWith)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Util (effectFailsWith, effectSucceedsWith)
|
||||
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ module Spec.Governor (tests) where
|
|||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..))
|
||||
import Agora.Governor.Scripts (governorPolicy, governorValidator)
|
||||
import Agora.Proposal (ProposalId (..))
|
||||
import Spec.Sample.Governor (createProposal, mintGATs, mintGST, mutateState)
|
||||
import Spec.Sample.Shared qualified as Shared
|
||||
import Spec.Util (policySucceedsWith, validatorSucceedsWith)
|
||||
import Sample.Governor (createProposal, mintGATs, mintGST, mutateState)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Util (policySucceedsWith, validatorSucceedsWith)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -35,11 +35,11 @@ import Agora.Stake.Scripts (stakeValidator)
|
|||
import Plutarch.SafeMoney (Tagged (Tagged))
|
||||
import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Sample.Proposal qualified as Proposal
|
||||
import Spec.Sample.Shared (signer, signer2)
|
||||
import Spec.Sample.Shared qualified as Shared
|
||||
import Spec.Util (policySucceedsWith, validatorSucceedsWith)
|
||||
import Sample.Proposal qualified as Proposal
|
||||
import Sample.Shared (signer, signer2)
|
||||
import Sample.Shared qualified as Shared
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Util (policySucceedsWith, validatorSucceedsWith)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,172 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Effect.TreasuryWithdrawalEffect
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Sample based testing for Treasury Withdrawal Effect
|
||||
|
||||
This module provides smaples for Treasury Withdrawal Effect tests.
|
||||
-}
|
||||
module Spec.Sample.Effect.TreasuryWithdrawal (
|
||||
inputTreasury,
|
||||
inputUser,
|
||||
inputGAT,
|
||||
inputCollateral,
|
||||
outputTreasury,
|
||||
outputUser,
|
||||
buildReceiversOutputFromDatum,
|
||||
currSymbol,
|
||||
users,
|
||||
treasuries,
|
||||
buildScriptContext,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (..),
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
DatumHash (DatumHash),
|
||||
PubKeyHash (PubKeyHash),
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (Spending),
|
||||
TokenName (TokenName),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (
|
||||
TxInfo,
|
||||
txInfoDCert,
|
||||
txInfoData,
|
||||
txInfoFee,
|
||||
txInfoId,
|
||||
txInfoInputs,
|
||||
txInfoMint,
|
||||
txInfoOutputs,
|
||||
txInfoSignatories,
|
||||
txInfoValidRange,
|
||||
txInfoWdrl
|
||||
),
|
||||
TxOut (..),
|
||||
TxOutRef (TxOutRef),
|
||||
Validator,
|
||||
ValidatorHash (ValidatorHash),
|
||||
Value,
|
||||
toBuiltin,
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
import Data.ByteString.Char8 qualified as C
|
||||
import Data.ByteString.Hash (sha2)
|
||||
|
||||
import Agora.Effect.TreasuryWithdrawal (
|
||||
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
||||
treasuryWithdrawalValidator,
|
||||
)
|
||||
|
||||
-- | A sample Currency Symbol.
|
||||
currSymbol :: CurrencySymbol
|
||||
currSymbol = CurrencySymbol "12312099"
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | List of users who the effect will pay to.
|
||||
users :: [Credential]
|
||||
users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
|
||||
|
||||
-- | List of users who the effect will pay to.
|
||||
treasuries :: [Credential]
|
||||
treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
|
||||
|
||||
inputGAT :: TxInInfo
|
||||
inputGAT =
|
||||
TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputTreasury :: Int -> Value -> TxInInfo
|
||||
inputTreasury indx val =
|
||||
TxInInfo
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (treasuries !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputUser :: Int -> Value -> TxInInfo
|
||||
inputUser indx val =
|
||||
TxInInfo
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputCollateral :: Int -> TxInInfo
|
||||
inputCollateral indx =
|
||||
TxInInfo -- Initiator
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = Value.singleton "" "" 2000000
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
outputTreasury :: Int -> Value -> TxOut
|
||||
outputTreasury indx val =
|
||||
TxOut
|
||||
{ txOutAddress = Address (treasuries !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
outputUser :: Int -> Value -> TxOut
|
||||
outputUser indx val =
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
|
||||
buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
|
||||
where
|
||||
f x =
|
||||
TxOut
|
||||
{ txOutAddress = Address (fst x) Nothing
|
||||
, txOutValue = snd x
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
-- | Effect validator instance.
|
||||
validator :: Validator
|
||||
validator = mkValidator $ treasuryWithdrawalValidator currSymbol
|
||||
|
||||
-- | 'TokenName' that represents the hash of the 'Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
|
||||
|
||||
buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
|
||||
buildScriptContext inputs outputs =
|
||||
ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs = inputs
|
||||
, txInfoOutputs = outputs
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData = []
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose =
|
||||
Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
}
|
||||
|
|
@ -1,622 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Governor
|
||||
Maintainer : connor@mlabs.city
|
||||
Description: Sample based testing for Governor utxos
|
||||
|
||||
This module tests primarily the happy path for Governor interactions
|
||||
-}
|
||||
module Spec.Sample.Governor (
|
||||
createProposal,
|
||||
mutateState,
|
||||
mintGATs,
|
||||
mintGST,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import Plutarch.SafeMoney.Tagged
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Address (scriptHashAddress)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (..),
|
||||
Credential (PubKeyCredential),
|
||||
Datum (..),
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (Minting, Spending),
|
||||
ToData (toBuiltinData),
|
||||
TokenName (..),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (..),
|
||||
TxOut (..),
|
||||
TxOutRef (..),
|
||||
Validator,
|
||||
ValidatorHash (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Scripts (unitDatum)
|
||||
import Plutus.V1.Ledger.Value (
|
||||
AssetClass (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Effect.NoOp (noOpValidator)
|
||||
import Agora.Governor (GovernorDatum (..), getNextProposalId)
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
ProposalId (..),
|
||||
ProposalStatus (..),
|
||||
ProposalVotes (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Proposal qualified as P
|
||||
import Agora.Stake (
|
||||
ProposalLock (..),
|
||||
Stake (..),
|
||||
StakeDatum (..),
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Spec.Sample.Shared (
|
||||
authorityTokenSymbol,
|
||||
defaultProposalThresholds,
|
||||
govAssetClass,
|
||||
govSymbol,
|
||||
govValidatorAddress,
|
||||
gstUTXORef,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorAddress,
|
||||
signer,
|
||||
signer2,
|
||||
stake,
|
||||
stakeAddress,
|
||||
stakeAssetClass,
|
||||
)
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | A valid 'ScriptContext' for minting GST.
|
||||
|
||||
- Only the minting policy will be ran in the transaction.
|
||||
- An arbitrary UTXO is spent to create the token.
|
||||
|
||||
- We call this the "witness" UTXO.
|
||||
- This UTXO is referenced in the 'Agora.Governor.Governor' parameter
|
||||
- The minting policy should only be ran once its life time,
|
||||
cause the GST cannot be minted twice or burnt.
|
||||
|
||||
- The output UTXO must carry a valid 'GovernorDatum'.
|
||||
- It's worth noticing that the transaction should send the GST to the governor validator,
|
||||
but unfortunately we can't check it in the policy. The GST will stay at the address of
|
||||
the governor validator forever once the token is under control of the said validator.
|
||||
|
||||
TODO: tag the output UTXO with the target address.
|
||||
-}
|
||||
mintGST :: ScriptContext
|
||||
mintGST =
|
||||
let gst = Value.assetClassValue govAssetClass 1
|
||||
|
||||
---
|
||||
|
||||
governorOutputDatum' :: GovernorDatum
|
||||
governorOutputDatum' =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 0
|
||||
}
|
||||
governorOutputDatum :: Datum
|
||||
governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
|
||||
governorOutput :: TxOut
|
||||
governorOutput =
|
||||
TxOut
|
||||
{ txOutAddress = govValidatorAddress
|
||||
, txOutValue = gst <> minAda
|
||||
, txOutDatumHash = Just $ toDatumHash governorOutputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
-- TODO: Can the witness be a script?
|
||||
witness :: PubKeyHash
|
||||
witness = "a926a9a72a0963f428e3252caa8354e655603996fb8892d6b8323fd072345924"
|
||||
witnessAddress :: Address
|
||||
witnessAddress = Address (PubKeyCredential witness) Nothing
|
||||
|
||||
---
|
||||
|
||||
-- The witness UTXO must be consumed.
|
||||
witnessInput :: TxOut
|
||||
witnessInput =
|
||||
TxOut
|
||||
{ txOutAddress = witnessAddress
|
||||
, txOutValue = mempty
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
witnessUTXO :: TxInInfo
|
||||
witnessUTXO = TxInInfo gstUTXORef witnessInput
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ witnessUTXO
|
||||
]
|
||||
, txInfoOutputs = [governorOutput]
|
||||
, -- Some ada to cover the transaction fee
|
||||
txInfoFee = Value.singleton "" "" 2
|
||||
, -- Exactly one GST is minted
|
||||
txInfoMint = gst
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [witness]
|
||||
, txInfoData = [datumPair governorOutputDatum]
|
||||
, txInfoId = "90906d3e6b4d6dec2e747dcdd9617940ea8358164c7244694cfa39dec18bd9d4"
|
||||
}
|
||||
, scriptContextPurpose = Minting govSymbol
|
||||
}
|
||||
|
||||
{- | A valid script context to create a proposal.
|
||||
|
||||
Three component will run in the transaction:
|
||||
TODO: mention redeemers
|
||||
|
||||
- Governor validator
|
||||
- Stake validator
|
||||
- Proposal policy
|
||||
|
||||
The components will ensure:
|
||||
|
||||
- The governor state UTXO is spent
|
||||
|
||||
- A new UTXO is paid back to governor validator, which carries the GST.
|
||||
- The proposal id in the state datum is advanced.
|
||||
|
||||
- A new UTXO is sent to the proposal validator
|
||||
|
||||
- The UTXO contains a newly minted proposal state token.
|
||||
- It also carries a legal proposal state datum, whose status is set to 'Agora.Proposal.Draft'.
|
||||
|
||||
- A stake is spent to create a proposal
|
||||
|
||||
- The stake owner must sign the transaction.
|
||||
- The output stake must paid back to the stake validator.
|
||||
- The output stake is locked by the newly created proposal.
|
||||
-}
|
||||
createProposal :: ScriptContext
|
||||
createProposal =
|
||||
let pst = Value.singleton proposalPolicySymbol "" 1
|
||||
gst = Value.assetClassValue govAssetClass 1
|
||||
sst = Value.assetClassValue stakeAssetClass 1
|
||||
stackedGTs = 424242424242
|
||||
thisProposalId = ProposalId 0
|
||||
|
||||
---
|
||||
|
||||
governorInputDatum' :: GovernorDatum
|
||||
governorInputDatum' =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = thisProposalId
|
||||
}
|
||||
governorInputDatum :: Datum
|
||||
governorInputDatum = Datum $ toBuiltinData governorInputDatum'
|
||||
governorInput :: TxOut
|
||||
governorInput =
|
||||
TxOut
|
||||
{ txOutAddress = govValidatorAddress
|
||||
, txOutValue = gst
|
||||
, txOutDatumHash = Just $ toDatumHash governorInputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
proposalDatum :: Datum
|
||||
proposalDatum =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
ProposalDatum
|
||||
{ P.proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
}
|
||||
)
|
||||
proposalOutput :: TxOut
|
||||
proposalOutput =
|
||||
TxOut
|
||||
{ txOutAddress = proposalValidatorAddress
|
||||
, txOutValue = pst <> minAda
|
||||
, txOutDatumHash = Just (toDatumHash proposalDatum)
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
stakeInputDatum' :: StakeDatum
|
||||
stakeInputDatum' =
|
||||
StakeDatum
|
||||
{ stakedAmount = Tagged stackedGTs
|
||||
, owner = signer
|
||||
, lockedBy = []
|
||||
}
|
||||
stakeInputDatum :: Datum
|
||||
stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
|
||||
stakeInput :: TxOut
|
||||
stakeInput =
|
||||
TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs
|
||||
, txOutDatumHash = Just (toDatumHash stakeInputDatum)
|
||||
}
|
||||
|
||||
---
|
||||
governorOutputDatum' :: GovernorDatum
|
||||
governorOutputDatum' = governorInputDatum' {nextProposalId = getNextProposalId thisProposalId}
|
||||
governorOutputDatum :: Datum
|
||||
governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
|
||||
governorOutput :: TxOut
|
||||
governorOutput =
|
||||
governorInput
|
||||
{ txOutDatumHash = Just $ toDatumHash governorOutputDatum
|
||||
, txOutValue = gst <> minAda
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
proposalLocks :: [ProposalLock]
|
||||
proposalLocks =
|
||||
[ ProposalLock (ResultTag 0) thisProposalId
|
||||
, ProposalLock (ResultTag 1) thisProposalId
|
||||
]
|
||||
stakeOutputDatum' :: StakeDatum
|
||||
stakeOutputDatum' = stakeInputDatum' {lockedBy = proposalLocks}
|
||||
stakeOutputDatum :: Datum
|
||||
stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
|
||||
stakeOutput :: TxOut
|
||||
stakeOutput =
|
||||
stakeInput
|
||||
{ txOutDatumHash = Just $ toDatumHash stakeOutputDatum
|
||||
, txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs <> minAda
|
||||
}
|
||||
|
||||
---
|
||||
ownInputRef :: TxOutRef
|
||||
ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
ownInputRef
|
||||
governorInput
|
||||
, TxInInfo
|
||||
(TxOutRef "4262bbd0b3fc926b74eaa8abab5def6ce5e6b94f19cf221c02a16e7da8cd470f" 1)
|
||||
stakeInput
|
||||
]
|
||||
, txInfoOutputs = [proposalOutput, governorOutput, stakeOutput]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = pst
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData =
|
||||
datumPair
|
||||
<$> [ governorInputDatum
|
||||
, governorOutputDatum
|
||||
, proposalDatum
|
||||
, stakeInputDatum
|
||||
, stakeOutputDatum
|
||||
]
|
||||
, txInfoId = "1ffb9669335c908d9a4774a4bf7aa7bfafec91d015249b4138bc83fde4a3330a"
|
||||
}
|
||||
, scriptContextPurpose = Spending ownInputRef
|
||||
}
|
||||
|
||||
{- This script context should be a valid transaction for minting authority for the effect scrips.
|
||||
|
||||
The following components will run:
|
||||
|
||||
- Governor validator
|
||||
- Authority policy
|
||||
- Proposal validator
|
||||
|
||||
There should be only one proposal the transaction.
|
||||
The validity of the proposal will be checked:
|
||||
|
||||
- It's in 'Agora.Proposal.Locked' state.
|
||||
- It has a 'winner' effect group, meaning that the votes meet the requirements.
|
||||
|
||||
The system will ensure that for every effect scrips in said effect group,
|
||||
a newly minted GAT is sent to the corresponding effect, and properly tagged.
|
||||
-}
|
||||
mintGATs :: ScriptContext
|
||||
mintGATs =
|
||||
let pst = Value.singleton proposalPolicySymbol "" 1
|
||||
gst = Value.assetClassValue govAssetClass 1
|
||||
gat = Value.assetClassValue atAssetClass 1
|
||||
|
||||
---
|
||||
|
||||
mockEffect :: Validator
|
||||
mockEffect = mkValidator $ noOpValidator ""
|
||||
mockEffectHash :: ValidatorHash
|
||||
mockEffectHash = validatorHash mockEffect
|
||||
mockEffectAddress :: Address
|
||||
mockEffectAddress = scriptHashAddress mockEffectHash
|
||||
mockEffectOutputDatum :: Datum
|
||||
mockEffectOutputDatum = unitDatum
|
||||
atTokenName :: TokenName
|
||||
atTokenName = TokenName hash
|
||||
where
|
||||
ValidatorHash hash = mockEffectHash
|
||||
atAssetClass :: AssetClass
|
||||
atAssetClass = AssetClass (authorityTokenSymbol, atTokenName)
|
||||
|
||||
---
|
||||
|
||||
governorInputDatum' :: GovernorDatum
|
||||
governorInputDatum' =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 5
|
||||
}
|
||||
governorInputDatum :: Datum
|
||||
governorInputDatum = Datum $ toBuiltinData governorInputDatum'
|
||||
governorInput :: TxOut
|
||||
governorInput =
|
||||
TxOut
|
||||
{ txOutAddress = govValidatorAddress
|
||||
, txOutValue = gst
|
||||
, txOutDatumHash = Just $ toDatumHash governorInputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.singleton mockEffectHash $ toDatumHash mockEffectOutputDatum)
|
||||
]
|
||||
proposalVotes :: ProposalVotes
|
||||
proposalVotes =
|
||||
ProposalVotes $
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, 100)
|
||||
, (ResultTag 1, 2000) -- The winner
|
||||
]
|
||||
proposalInputDatum' :: ProposalDatum
|
||||
proposalInputDatum' =
|
||||
ProposalDatum
|
||||
{ P.proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Locked
|
||||
, -- TODO: Any need to check minimun amount of cosigners here?
|
||||
cosigners = [signer, signer2]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = proposalVotes
|
||||
}
|
||||
proposalInputDatum :: Datum
|
||||
proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
|
||||
proposalInput :: TxOut
|
||||
proposalInput =
|
||||
TxOut
|
||||
{ txOutAddress = proposalValidatorAddress
|
||||
, txOutValue = pst
|
||||
, txOutDatumHash = Just (toDatumHash proposalInputDatum)
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
governorOutputDatum' :: GovernorDatum
|
||||
governorOutputDatum' = governorInputDatum'
|
||||
governorOutputDatum :: Datum
|
||||
governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
|
||||
governorOutput :: TxOut
|
||||
governorOutput =
|
||||
governorInput
|
||||
{ txOutDatumHash = Just $ toDatumHash governorOutputDatum
|
||||
, txOutValue = gst <> minAda
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
proposalOutputDatum' :: ProposalDatum
|
||||
proposalOutputDatum' = proposalInputDatum' {status = Finished}
|
||||
proposalOutputDatum :: Datum
|
||||
proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
|
||||
proposalOutput :: TxOut
|
||||
proposalOutput =
|
||||
proposalInput
|
||||
{ txOutDatumHash = Just $ toDatumHash proposalOutputDatum
|
||||
, txOutValue = pst <> minAda
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
mockEffectOutput :: TxOut
|
||||
mockEffectOutput =
|
||||
TxOut
|
||||
{ txOutAddress = mockEffectAddress
|
||||
, txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum
|
||||
, txOutValue = gat <> minAda
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
ownInputRef :: TxOutRef
|
||||
ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo ownInputRef governorInput
|
||||
, TxInInfo
|
||||
(TxOutRef "11b2162f267614b803761032b6333040fc61478ae788c088614ee9487ab0c1b7" 1)
|
||||
proposalInput
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ governorOutput
|
||||
, proposalOutput
|
||||
, mockEffectOutput
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = gat
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer, signer2]
|
||||
, txInfoData =
|
||||
datumPair
|
||||
<$> [ governorInputDatum
|
||||
, governorOutputDatum
|
||||
, proposalInputDatum
|
||||
, proposalOutputDatum
|
||||
, mockEffectOutputDatum
|
||||
]
|
||||
, txInfoId = "ff755f613c1f7487dfbf231325c67f481f7a97e9faf4d8b09ad41176fd65cbe7"
|
||||
}
|
||||
, scriptContextPurpose = Spending ownInputRef
|
||||
}
|
||||
|
||||
{- | A valid script context for changing the state datum of the governor.
|
||||
|
||||
In this case, the following components will run:
|
||||
|
||||
* Governor validator
|
||||
* Effect script
|
||||
|
||||
The effect script should carry an valid tagged authority token,
|
||||
and said token will be burnt in the transaction. We use 'noOpValidator'
|
||||
here as a mock effect, so no actual change is done to the governor state.
|
||||
TODO: use 'mutateGovernorEffect' as the mock effect in the future.
|
||||
|
||||
The governor will ensure the new governor state is valid.
|
||||
-}
|
||||
mutateState :: ScriptContext
|
||||
mutateState =
|
||||
let gst = Value.assetClassValue govAssetClass 1
|
||||
gat = Value.assetClassValue atAssetClass 1
|
||||
burntGAT = Value.assetClassValue atAssetClass (-1)
|
||||
|
||||
---
|
||||
|
||||
-- TODO: Use the *real* effect, see https://github.com/Liqwid-Labs/agora/pull/62
|
||||
|
||||
mockEffect :: Validator
|
||||
mockEffect = mkValidator $ noOpValidator ""
|
||||
mockEffectHash :: ValidatorHash
|
||||
mockEffectHash = validatorHash mockEffect
|
||||
mockEffectAddress :: Address
|
||||
mockEffectAddress = scriptHashAddress mockEffectHash
|
||||
atTokenName :: TokenName
|
||||
atTokenName = TokenName hash
|
||||
where
|
||||
ValidatorHash hash = mockEffectHash
|
||||
atAssetClass :: AssetClass
|
||||
atAssetClass = AssetClass (authorityTokenSymbol, atTokenName)
|
||||
|
||||
--
|
||||
|
||||
mockEffectInputDatum :: Datum
|
||||
mockEffectInputDatum = unitDatum
|
||||
mockEffectInput :: TxOut
|
||||
mockEffectInput =
|
||||
TxOut
|
||||
{ txOutAddress = mockEffectAddress
|
||||
, txOutValue = gat -- Will be burnt
|
||||
, txOutDatumHash = Just $ toDatumHash mockEffectInputDatum
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
mockEffectOutputDatum :: Datum
|
||||
mockEffectOutputDatum = mockEffectInputDatum
|
||||
mockEffectOutput :: TxOut
|
||||
mockEffectOutput =
|
||||
mockEffectInput
|
||||
{ txOutValue = minAda
|
||||
, txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
governorInputDatum' :: GovernorDatum
|
||||
governorInputDatum' =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 5
|
||||
}
|
||||
governorInputDatum :: Datum
|
||||
governorInputDatum = Datum $ toBuiltinData governorInputDatum'
|
||||
governorInput :: TxOut
|
||||
governorInput =
|
||||
TxOut
|
||||
{ txOutAddress = govValidatorAddress
|
||||
, txOutValue = gst
|
||||
, txOutDatumHash = Just $ toDatumHash governorInputDatum
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
governorOutputDatum' :: GovernorDatum
|
||||
governorOutputDatum' = governorInputDatum'
|
||||
governorOutputDatum :: Datum
|
||||
governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
|
||||
governorOutput :: TxOut
|
||||
governorOutput =
|
||||
governorInput
|
||||
{ txOutDatumHash = Just $ toDatumHash governorOutputDatum
|
||||
, txOutValue = gst <> minAda
|
||||
}
|
||||
|
||||
--
|
||||
|
||||
ownInputRef :: TxOutRef
|
||||
ownInputRef = TxOutRef "f867238a04597c99a0b9858746557d305025cca3b9f78ea14d5c88c4cfcf58ff" 1
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo ownInputRef governorInput
|
||||
, TxInInfo
|
||||
(TxOutRef "ecff06d7cf99089294569cc8b92609e44927278f9901730715d14634fbc10089" 1)
|
||||
mockEffectInput
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ governorOutput
|
||||
, mockEffectOutput
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = burntGAT
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData =
|
||||
datumPair
|
||||
<$> [ governorInputDatum
|
||||
, governorOutputDatum
|
||||
, mockEffectInputDatum
|
||||
, mockEffectOutputDatum
|
||||
]
|
||||
, txInfoId = "9a12a605086a9f866731869a42d0558036fc739c74fea3849aa41562c015aaf9"
|
||||
}
|
||||
, scriptContextPurpose = Spending ownInputRef
|
||||
}
|
||||
|
|
@ -1,234 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Proposal
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Sample based testing for Proposal utxos
|
||||
|
||||
This module tests primarily the happy path for Proposal interactions
|
||||
-}
|
||||
module Spec.Sample.Proposal (
|
||||
-- * Script contexts
|
||||
proposalCreation,
|
||||
cosignProposal,
|
||||
proposalRef,
|
||||
stakeRef,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Plutarch.Api.V1 (
|
||||
validatorHash,
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
Datum (Datum),
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
ToData (toBuiltinData),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (..),
|
||||
TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
|
||||
TxOutRef (TxOutRef),
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Governor (
|
||||
GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
|
||||
)
|
||||
import Agora.Proposal (
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalId (..),
|
||||
ProposalStatus (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
|
||||
import Plutarch.SafeMoney (Tagged (Tagged), untag)
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Sample.Shared
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
proposalCreation :: ScriptContext
|
||||
proposalCreation =
|
||||
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
proposalDatum :: Datum
|
||||
proposalDatum =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
ProposalDatum
|
||||
{ proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
}
|
||||
)
|
||||
|
||||
govBefore :: Datum
|
||||
govBefore =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 0
|
||||
}
|
||||
)
|
||||
govAfter :: Datum
|
||||
govAfter =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 1
|
||||
}
|
||||
)
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
|
||||
, txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1
|
||||
, txOutDatumHash = Just (toDatumHash govBefore)
|
||||
}
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash proposalDatum)
|
||||
}
|
||||
, TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.assetClassValue proposal.governorSTAssetClass 1
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash govAfter)
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData =
|
||||
[ datumPair proposalDatum
|
||||
, datumPair govBefore
|
||||
, datumPair govAfter
|
||||
]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose = Minting proposalPolicySymbol
|
||||
}
|
||||
|
||||
proposalRef :: TxOutRef
|
||||
proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
|
||||
|
||||
stakeRef :: TxOutRef
|
||||
stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
cosignProposal :: [PubKeyHash] -> TxInfo
|
||||
cosignProposal newSigners =
|
||||
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
proposalBefore :: ProposalDatum
|
||||
proposalBefore =
|
||||
ProposalDatum
|
||||
{ proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
}
|
||||
stakeDatum :: StakeDatum
|
||||
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
|
||||
proposalAfter :: ProposalDatum
|
||||
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
|
||||
in TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
proposalRef
|
||||
TxOut
|
||||
{ txOutAddress = proposalValidatorAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash proposalBefore)
|
||||
}
|
||||
, TxInInfo
|
||||
stakeRef
|
||||
TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.singleton "" "" 10_000_000
|
||||
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
|
||||
, Value.assetClassValue stakeAssetClass 1
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash stakeDatum)
|
||||
}
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
|
||||
}
|
||||
, TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.singleton "" "" 10_000_000
|
||||
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
|
||||
, Value.assetClassValue stakeAssetClass 1
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash stakeDatum)
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = newSigners
|
||||
, txInfoData =
|
||||
[ datumPair . Datum $ toBuiltinData proposalBefore
|
||||
, datumPair . Datum $ toBuiltinData proposalAfter
|
||||
, datumPair . Datum $ toBuiltinData stakeDatum
|
||||
]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
|
|
@ -1,229 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Shared
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Shared useful values for creating Samples for testing.
|
||||
|
||||
Shared useful values for creating Samples for testing.
|
||||
-}
|
||||
module Spec.Sample.Shared (
|
||||
-- * Misc
|
||||
signer,
|
||||
signer2,
|
||||
minAda,
|
||||
|
||||
-- * Components
|
||||
|
||||
-- ** Stake
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeValidatorHash,
|
||||
stakeAddress,
|
||||
stakeSymbol,
|
||||
|
||||
-- ** Governor
|
||||
governor,
|
||||
govPolicy,
|
||||
govValidator,
|
||||
govSymbol,
|
||||
govAssetClass,
|
||||
govValidatorAddress,
|
||||
govValidatorHash,
|
||||
gstUTXORef,
|
||||
|
||||
-- ** Proposal
|
||||
defaultProposalThresholds,
|
||||
proposal,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
proposalValidatorAddress,
|
||||
|
||||
-- ** Authority
|
||||
authorityToken,
|
||||
authorityTokenSymbol,
|
||||
|
||||
-- ** Treasury
|
||||
treasuryOut,
|
||||
gatTn,
|
||||
gatCs,
|
||||
mockTrEffect,
|
||||
trCredential,
|
||||
wrongEffHash,
|
||||
) where
|
||||
|
||||
import Agora.AuthorityToken
|
||||
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.Stake (Stake (..))
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
import Plutarch.SafeMoney
|
||||
import Plutus.V1.Ledger.Address (scriptHashAddress)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
CurrencySymbol,
|
||||
MintingPolicy (..),
|
||||
PubKeyHash,
|
||||
TxOutRef (TxOutRef),
|
||||
Value,
|
||||
)
|
||||
import Plutus.V1.Ledger.Contexts (
|
||||
TxOut (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
|
||||
import Plutus.V1.Ledger.Value (AssetClass, TokenName)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
governor :: Governor
|
||||
governor = Governor oref gt mc
|
||||
where
|
||||
oref = gstUTXORef
|
||||
gt =
|
||||
Tagged $
|
||||
Value.assetClass
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
mc = 6
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy (governorPolicy governor)
|
||||
|
||||
govValidator :: Validator
|
||||
govValidator = mkValidator (governorValidator governor)
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
||||
govAssetClass :: AssetClass
|
||||
govAssetClass = governorSTAssetClassFromGovernor governor
|
||||
|
||||
govValidatorHash :: ValidatorHash
|
||||
govValidatorHash = governorValidatorHash governor
|
||||
|
||||
govValidatorAddress :: Address
|
||||
govValidatorAddress = scriptHashAddress govValidatorHash
|
||||
|
||||
proposal :: Proposal
|
||||
proposal = proposalFromGovernor governor
|
||||
|
||||
proposalPolicySymbol :: CurrencySymbol
|
||||
proposalPolicySymbol = proposalSTSymbolFromGovernor governor
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | Another sample 'PubKeyHash'.
|
||||
signer2 :: PubKeyHash
|
||||
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
|
||||
|
||||
proposalValidatorHash :: ValidatorHash
|
||||
proposalValidatorHash = proposalValidatorHashFromGovernor governor
|
||||
|
||||
proposalValidatorAddress :: Address
|
||||
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
|
||||
|
||||
defaultProposalThresholds :: ProposalThresholds
|
||||
defaultProposalThresholds =
|
||||
ProposalThresholds
|
||||
{ countVoting = Tagged 1000
|
||||
, create = Tagged 1
|
||||
, startVoting = Tagged 10
|
||||
}
|
||||
|
||||
authorityToken :: AuthorityToken
|
||||
authorityToken = authorityTokenFromGovernor governor
|
||||
|
||||
authorityTokenSymbol :: CurrencySymbol
|
||||
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
|
||||
|
||||
------------------------------------------------------------------
|
||||
|
||||
treasuryOut :: TxOut
|
||||
treasuryOut =
|
||||
TxOut
|
||||
{ txOutAddress = Address trCredential Nothing
|
||||
, txOutValue = minAda
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
|
||||
of a valid governance authority token (GAT).
|
||||
-}
|
||||
gatCs :: CurrencySymbol
|
||||
gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
|
||||
trValidator :: Validator
|
||||
trValidator = mkValidator (treasuryValidator gatCs)
|
||||
|
||||
-- | `ScriptCredential` used for the dummy treasury validator.
|
||||
trCredential :: Credential
|
||||
trCredential = ScriptCredential $ validatorHash trValidator
|
||||
|
||||
-- | `TokenName` for GAT generated from address of `mockTrEffect`.
|
||||
gatTn :: TokenName
|
||||
gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
|
||||
|
||||
-- | Mock treasury effect script, used for testing.
|
||||
mockTrEffect :: Validator
|
||||
mockTrEffect = mkValidator $ noOpValidator gatCs
|
||||
|
||||
{- | A SHA-256 hash which (in all certainty) should not match the
|
||||
hash of the dummy effect script.
|
||||
-}
|
||||
wrongEffHash :: ValidatorHash
|
||||
wrongEffHash =
|
||||
ValidatorHash
|
||||
"a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
|
||||
|
||||
------------------------------------------------------------------
|
||||
|
||||
minAda :: Value
|
||||
minAda = Value.singleton "" "" 10_000_000
|
||||
|
|
@ -1,162 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Stake
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Sample based testing for Stake utxos
|
||||
|
||||
This module tests primarily the happy path for Stake creation
|
||||
-}
|
||||
module Spec.Sample.Stake (
|
||||
stake,
|
||||
stakeAssetClass,
|
||||
stakeSymbol,
|
||||
validatorHashTN,
|
||||
signer,
|
||||
|
||||
-- * Script contexts
|
||||
stakeCreation,
|
||||
stakeCreationWrongDatum,
|
||||
stakeCreationUnsigned,
|
||||
stakeDepositWithdraw,
|
||||
DepositWithdrawExample (..),
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Plutarch.Api.V1 (
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
Datum (Datum),
|
||||
DatumHash (DatumHash),
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
ToData (toBuiltinData),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (..),
|
||||
TxOut (txOutAddress, txOutDatumHash, txOutValue),
|
||||
ValidatorHash (ValidatorHash),
|
||||
)
|
||||
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value (TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Plutarch.SafeMoney
|
||||
import Spec.Sample.Shared
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 'TokenName' that represents the hash of the 'Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
stakeCreation :: ScriptContext
|
||||
stakeCreation =
|
||||
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
|
||||
datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs = []
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData = [("", datum)]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
-- | This ScriptContext should fail because the datum has too much GT.
|
||||
stakeCreationWrongDatum :: ScriptContext
|
||||
stakeCreationWrongDatum =
|
||||
let datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
-- | This ScriptContext should fail because the datum has too much GT.
|
||||
stakeCreationUnsigned :: ScriptContext
|
||||
stakeCreationUnsigned =
|
||||
ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
stakeCreation.scriptContextTxInfo
|
||||
{ txInfoSignatories = []
|
||||
}
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Config for creating a ScriptContext that deposits or withdraws.
|
||||
data DepositWithdrawExample = DepositWithdrawExample
|
||||
{ startAmount :: Tagged GTTag Integer
|
||||
-- ^ The amount of GT stored before the transaction.
|
||||
, delta :: Tagged GTTag Integer
|
||||
-- ^ The amount of GT deposited or withdrawn from the Stake.
|
||||
}
|
||||
|
||||
-- | Create a ScriptContext that deposits or withdraws, given the config for it.
|
||||
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
|
||||
stakeDepositWithdraw config =
|
||||
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
|
||||
stakeBefore :: StakeDatum
|
||||
stakeBefore = StakeDatum config.startAmount signer []
|
||||
|
||||
stakeAfter :: StakeDatum
|
||||
stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData = [datumPair stakeAfter]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
}
|
||||
|
|
@ -1,163 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module: Spec.Sample.Treasury
|
||||
Description: Sample data for `Spec.Treasury`.
|
||||
Maintainer: jack@mlabs.city
|
||||
|
||||
This module contains sample data, used in the tests written in
|
||||
`Spec.Treasury`.
|
||||
-}
|
||||
module Spec.Sample.Treasury (
|
||||
gatCs,
|
||||
validCtx,
|
||||
treasuryRef,
|
||||
gatTn,
|
||||
walletIn,
|
||||
trCtxGATNameNotAddress,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (validatorHash)
|
||||
import Plutus.V1.Ledger.Address (Address (..))
|
||||
import Plutus.V1.Ledger.Api (
|
||||
BuiltinByteString,
|
||||
Credential (PubKeyCredential),
|
||||
PubKeyHash (PubKeyHash),
|
||||
)
|
||||
import Plutus.V1.Ledger.Contexts (
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (Minting),
|
||||
TxInInfo (..),
|
||||
TxInfo (..),
|
||||
TxOut (..),
|
||||
TxOutRef (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Scripts (
|
||||
ValidatorHash (ValidatorHash),
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import Spec.Sample.Shared (
|
||||
gatCs,
|
||||
gatTn,
|
||||
minAda,
|
||||
mockTrEffect,
|
||||
signer,
|
||||
treasuryOut,
|
||||
wrongEffHash,
|
||||
)
|
||||
import Spec.Util (datumPair)
|
||||
|
||||
{- | A `ScriptContext` that should be compatible with treasury
|
||||
transactions.
|
||||
-}
|
||||
validCtx :: ScriptContext
|
||||
validCtx =
|
||||
ScriptContext
|
||||
{ scriptContextPurpose = Minting gatCs
|
||||
, scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ treasuryIn
|
||||
, effectIn
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ treasuryOut
|
||||
]
|
||||
, -- Ensure sufficient ADA for transaction costs.
|
||||
txInfoFee = Value.singleton "" "" 2 -- 2 ADA.
|
||||
, -- Burn the GAT.
|
||||
txInfoMint = Value.singleton gatCs gatTn (-1)
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData =
|
||||
[ datumPair treasuryIn
|
||||
, datumPair treasuryOut
|
||||
, datumPair effectIn
|
||||
]
|
||||
, txInfoId =
|
||||
"73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
}
|
||||
}
|
||||
where
|
||||
treasuryIn =
|
||||
TxInInfo
|
||||
{ txInInfoOutRef = treasuryRef
|
||||
, txInInfoResolved = treasuryOut
|
||||
}
|
||||
effectIn =
|
||||
TxInInfo
|
||||
{ txInInfoOutRef = effectRef
|
||||
, txInInfoResolved =
|
||||
TxOut
|
||||
{ txOutAddress =
|
||||
Address (ScriptCredential $ validatorHash mockTrEffect) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.singleton gatCs gatTn 1
|
||||
, minAda
|
||||
]
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
-- | Reference to treasury output.
|
||||
treasuryRef :: TxOutRef
|
||||
treasuryRef =
|
||||
TxOutRef
|
||||
"73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
1
|
||||
|
||||
-- | Reference to dummy effect output.
|
||||
effectRef :: TxOutRef
|
||||
effectRef =
|
||||
TxOutRef
|
||||
"52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
|
||||
0
|
||||
|
||||
-- | Input representing a user wallet with a valid GAT.
|
||||
walletIn :: TxInInfo
|
||||
walletIn =
|
||||
TxInInfo
|
||||
{ txInInfoOutRef =
|
||||
TxOutRef
|
||||
"cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83"
|
||||
0
|
||||
, txInInfoResolved =
|
||||
TxOut
|
||||
{ txOutDatumHash = Nothing
|
||||
, txOutValue = Value.singleton gatCs gatTn 1
|
||||
, txOutAddress =
|
||||
Address
|
||||
(PubKeyCredential $ PubKeyHash addressBs)
|
||||
Nothing
|
||||
}
|
||||
}
|
||||
|
||||
addressBs :: BuiltinByteString
|
||||
(ValidatorHash addressBs) = validatorHash mockTrEffect
|
||||
|
||||
trCtxGATNameNotAddress :: ScriptContext
|
||||
trCtxGATNameNotAddress =
|
||||
let txInfo = validCtx.scriptContextTxInfo
|
||||
inputs = txInfo.txInfoInputs
|
||||
effectIn = inputs !! 1
|
||||
invalidEff =
|
||||
effectIn
|
||||
{ txInInfoResolved =
|
||||
effectIn.txInInfoResolved
|
||||
{ txOutAddress = Address (ScriptCredential wrongEffHash) Nothing
|
||||
}
|
||||
}
|
||||
in validCtx
|
||||
{ scriptContextTxInfo =
|
||||
txInfo
|
||||
{ txInfoInputs =
|
||||
[ head inputs
|
||||
, invalidEff
|
||||
]
|
||||
}
|
||||
}
|
||||
|
|
@ -24,9 +24,9 @@ import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Spec.Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
|
||||
import Spec.Sample.Stake qualified as Stake
|
||||
import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWith, validatorSucceedsWith)
|
||||
import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
|
||||
import Sample.Stake qualified as Stake
|
||||
import Test.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWith, validatorSucceedsWith)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -37,10 +37,10 @@ import Plutus.V1.Ledger.Credential (
|
|||
StakingCredential (StakingHash),
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import Spec.Sample.Shared (
|
||||
import Sample.Shared (
|
||||
trCredential,
|
||||
)
|
||||
import Spec.Sample.Treasury (
|
||||
import Sample.Treasury (
|
||||
gatCs,
|
||||
gatTn,
|
||||
trCtxGATNameNotAddress,
|
||||
|
|
@ -48,8 +48,8 @@ import Spec.Sample.Treasury (
|
|||
validCtx,
|
||||
walletIn,
|
||||
)
|
||||
import Spec.Util (validatorFailsWith, validatorSucceedsWith)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Util (validatorFailsWith, validatorSucceedsWith)
|
||||
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
|
|
|
|||
|
|
@ -1,233 +0,0 @@
|
|||
{- |
|
||||
Module : Spec.Util
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Utility functions for testing Plutarch scripts with ScriptContext
|
||||
|
||||
Utility functions for testing Plutarch scripts with ScriptContext:
|
||||
|
||||
- 'policySucceedsWith': checks that a minting policy succeeds.
|
||||
|
||||
- 'policyFailsWith': checks that a minting policy fails.
|
||||
|
||||
- 'validatorSucceedsWith': checks that validator succeeds.
|
||||
|
||||
- 'validatorFailsWith': checks that validator fails.
|
||||
|
||||
- 'effectSucceedsWith': checks that effect succeeds.
|
||||
|
||||
- 'effectFailsWith': checks that effect fails.
|
||||
|
||||
- 'scriptSucceeds': checks that an arbitrary script does not
|
||||
`perror`.
|
||||
|
||||
- 'scriptFails': checks that an arbitrary script `perror`s out.
|
||||
-}
|
||||
module Spec.Util (
|
||||
-- * Testing utils
|
||||
scriptSucceeds,
|
||||
scriptFails,
|
||||
policySucceedsWith,
|
||||
policyFailsWith,
|
||||
validatorSucceedsWith,
|
||||
validatorFailsWith,
|
||||
effectSucceedsWith,
|
||||
effectFailsWith,
|
||||
|
||||
-- * Plutus-land utils
|
||||
datumHash,
|
||||
toDatum,
|
||||
toDatumHash,
|
||||
datumPair,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Codec.Serialise (serialise)
|
||||
import Data.ByteString.Lazy qualified as ByteString.Lazy
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.HUnit (assertFailure, testCase)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Crypto (pblake2b_256)
|
||||
import Plutarch.Evaluate (evalScript)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import Plutus.V1.Ledger.Contexts (ScriptContext)
|
||||
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
|
||||
import PlutusTx.Builtins qualified as PlutusTx
|
||||
import PlutusTx.IsData qualified as PlutusTx
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Check that a policy script succeeds, given a name and arguments.
|
||||
policySucceedsWith ::
|
||||
( PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PMintingPolicy ->
|
||||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
policySucceedsWith tag policy redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
compile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
|
||||
-- | Check that a policy script fails, given a name and arguments.
|
||||
policyFailsWith ::
|
||||
( PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PMintingPolicy ->
|
||||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
policyFailsWith tag policy redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
compile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
|
||||
-- | Check that a validator script succeeds, given a name and arguments.
|
||||
validatorSucceedsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
, PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
validatorSucceedsWith tag validator datum redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
compile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
|
||||
-- | Check that a validator script fails, given a name and arguments.
|
||||
validatorFailsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
, PLift redeemer
|
||||
, PlutusTx.ToData (PLifted redeemer)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
validatorFailsWith tag validator datum redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
compile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
|
||||
{- | Check that a validator script succeeds, given a name and arguments.
|
||||
TODO: Change docstring.
|
||||
-}
|
||||
effectSucceedsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
|
||||
|
||||
-- TODO: Change docstring.
|
||||
|
||||
{- | Check that a validator script fails, given a name and arguments.
|
||||
TODO: Change docstring.
|
||||
-}
|
||||
effectFailsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
|
||||
|
||||
-- | Check that an arbitrary script doesn't error when evaluated, given a name.
|
||||
scriptSucceeds :: String -> Script -> TestTree
|
||||
scriptSucceeds name script = testCase name $ do
|
||||
let (res, _budget, traces) = evalScript script
|
||||
case res of
|
||||
Left e -> do
|
||||
assertFailure $
|
||||
show e <> " Traces: " <> show traces
|
||||
Right _v ->
|
||||
pure ()
|
||||
|
||||
-- | Check that an arbitrary script **does** error when evaluated, given a name.
|
||||
scriptFails :: String -> Script -> TestTree
|
||||
scriptFails name script = testCase name $ do
|
||||
let (res, _budget, traces) = evalScript script
|
||||
case res of
|
||||
Left _e ->
|
||||
pure ()
|
||||
Right v ->
|
||||
assertFailure $
|
||||
"Expected failure, but succeeded. " <> show v <> " Traces: " <> show traces
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Create a pair from data for use in 'txInfoData'.
|
||||
|
||||
Example:
|
||||
@
|
||||
myTxInfo { 'txInfoData' = ['datumPair' myDatum] }
|
||||
@
|
||||
-}
|
||||
datumPair :: PlutusTx.ToData a => a -> (DatumHash, Datum)
|
||||
datumPair = (,) <$> toDatumHash <*> toDatum
|
||||
|
||||
-- | Calculate the blake2b-256 hash of a Datum.
|
||||
datumHash :: Datum -> DatumHash
|
||||
datumHash (Datum data') = toDatumHash data'
|
||||
|
||||
-- | Convenience function to create a Datum from any type that implements ToData.
|
||||
toDatum :: PlutusTx.ToData a => a -> Datum
|
||||
toDatum = Datum . PlutusTx.toBuiltinData
|
||||
|
||||
{- | Calculate the blake2b-256 hash of any type that implements ToData
|
||||
|
||||
Shamelessly go through plutus.
|
||||
-}
|
||||
toDatumHash :: PlutusTx.ToData a => a -> DatumHash
|
||||
toDatumHash datum =
|
||||
DatumHash $
|
||||
PlutusTx.toBuiltin $
|
||||
plift $
|
||||
pblake2b_256
|
||||
# pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum)
|
||||
13
agora-test/Spec/Utils.hs
Normal file
13
agora-test/Spec/Utils.hs
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
{- |
|
||||
Module : Spec.Utils
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Tests for utility functions in 'Agora.Utils'.
|
||||
|
||||
Tests for utility functions in 'Agora.Utils'.
|
||||
-}
|
||||
module Spec.Utils (tests) where
|
||||
|
||||
import Test.Tasty (TestTree)
|
||||
|
||||
tests :: [TestTree]
|
||||
tests = []
|
||||
Loading…
Add table
Add a link
Reference in a new issue