offload some stuff from agora-test to agora-sample and agora-testlib
This commit is contained in:
fanghr
parent
3d414b334a
commit
283edd64b7
12 changed files with 56 additions and 39 deletions
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -34,11 +34,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,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, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
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, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
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.singleton stakeSymbol "" 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.singleton stakeSymbol "" 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,193 +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,
|
||||
stakeSymbol,
|
||||
stakeValidatorHash,
|
||||
stakeAddress,
|
||||
|
||||
-- ** Governor
|
||||
governor,
|
||||
govPolicy,
|
||||
govValidator,
|
||||
govSymbol,
|
||||
|
||||
-- ** Proposal
|
||||
defaultProposalThresholds,
|
||||
proposal,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
proposalValidatorAddress,
|
||||
|
||||
-- ** Treasury
|
||||
treasuryOut,
|
||||
gatTn,
|
||||
gatCs,
|
||||
mockTrEffect,
|
||||
trCredential,
|
||||
wrongEffHash,
|
||||
) where
|
||||
|
||||
import Agora.Effect.NoOp (noOpValidator)
|
||||
import Agora.Governor (
|
||||
Governor (Governor),
|
||||
governorPolicy,
|
||||
governorValidator,
|
||||
)
|
||||
import Agora.Proposal (
|
||||
Proposal (..),
|
||||
ProposalThresholds (..),
|
||||
)
|
||||
import Agora.Proposal.Scripts (
|
||||
proposalPolicy,
|
||||
proposalValidator,
|
||||
)
|
||||
import Agora.Stake (Stake (..))
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
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,
|
||||
)
|
||||
import Plutus.V1.Ledger.Contexts (
|
||||
TxOut (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
|
||||
import Plutus.V1.Ledger.Value (TokenName, Value)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
stake :: Stake
|
||||
stake =
|
||||
Stake
|
||||
{ gtClassRef =
|
||||
Tagged $
|
||||
Value.assetClass
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
, proposalSTClass = Value.assetClass proposalPolicySymbol ""
|
||||
}
|
||||
|
||||
stakeSymbol :: CurrencySymbol
|
||||
stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
|
||||
|
||||
stakeValidatorHash :: ValidatorHash
|
||||
stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake)
|
||||
|
||||
stakeAddress :: Address
|
||||
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
|
||||
governor :: Governor
|
||||
governor = Governor
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy (governorPolicy governor)
|
||||
|
||||
govValidator :: Validator
|
||||
govValidator = mkValidator (governorValidator governor)
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
||||
proposal :: Proposal
|
||||
proposal =
|
||||
Proposal
|
||||
{ governorSTAssetClass = Value.assetClass govSymbol ""
|
||||
, stakeSTAssetClass = Value.assetClass stakeSymbol ""
|
||||
, maximumCosigners = 6
|
||||
}
|
||||
|
||||
proposalPolicySymbol :: CurrencySymbol
|
||||
proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | Another sample 'PubKeyHash'.
|
||||
signer2 :: PubKeyHash
|
||||
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
|
||||
|
||||
proposalValidatorHash :: ValidatorHash
|
||||
proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal)
|
||||
|
||||
proposalValidatorAddress :: Address
|
||||
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
|
||||
|
||||
defaultProposalThresholds :: ProposalThresholds
|
||||
defaultProposalThresholds =
|
||||
ProposalThresholds
|
||||
{ countVoting = Tagged 1000
|
||||
, create = Tagged 1
|
||||
, startVoting = Tagged 10
|
||||
}
|
||||
|
||||
------------------------------------------------------------------
|
||||
|
||||
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,161 +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,
|
||||
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.singleton stakeSymbol validatorHashTN 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.singleton stakeSymbol validatorHashTN 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue