Sulkta-Coop/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Reset progress on treasury testing; will continue without apropos

Browse source
This commit is contained in:
Jack Hodgkinson 2022-04-29 15:23:08 +01:00
commit dafa6fe8f0
37 changed files with 3029 additions and 1191 deletions
Download patch file Download diff file Expand all files Collapse all files

11
agora-test/README.org Normal file
View file

@ -0,0 +1,11 @@
#+Title: Agora Test
This folder is the test suite for Agora governance system.
- =/Spec= contains different tests for different elements of Agora.
- =/Spec/Model= contain =apropos-tx= model for logical suite
generation and tests.
- =/Spec/Sample= contains primitive hand-made example values.
- =Util.hs= contains helper functions
Currently, planning to introduce =plutarch-test= for unit tests,
benchmarks, and golden tests.

22
agora-test/Spec.hs
View file

@ -10,8 +10,10 @@ import Test.Tasty (defaultMain, testGroup)
--------------------------------------------------------------------------------
import Spec.AuthorityToken qualified as AuthorityToken
import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
import Spec.Model.MultiSig qualified as MultiSig
import Spec.Model.Treasury qualified as Treasury
import Spec.Proposal qualified as Proposal
import Spec.Stake qualified as Stake
-- | The Agora test suite.
@ -21,8 +23,17 @@ main =
testGroup
"test suite"
[ testGroup
"Effects"
[ testGroup
"Treasury Withdrawal Effect"
TreasuryWithdrawal.tests
]
, testGroup
"Stake tests"
Stake.tests
, testGroup
"Proposal tests"
Proposal.tests
, testGroup
"Multisig tests"
[ testGroup
@ -32,11 +43,6 @@ main =
]
]
, testGroup
"Treasury tests"
[ testGroup
"Treasury"
[ Treasury.genTests
, Treasury.plutarchTests
]
]
"AuthorityToken tests"
AuthorityToken.tests
]

154
agora-test/Spec/AuthorityToken.hs Normal file
View file

@ -0,0 +1,154 @@
{-# LANGUAGE QuasiQuotes #-}
{- |
Module : Spec.AuthorityToken
Maintainer : emi@haskell.fyi
Description: Tests for Authority token functions
Tests for Authority token functions
-}
module Spec.AuthorityToken (tests) where
--------------------------------------------------------------------------------
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Plutarch
import Test.Tasty (TestTree, testGroup)
import Prelude
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (
Address (Address),
Credential (PubKeyCredential, ScriptCredential),
CurrencySymbol,
Script,
TxInInfo (TxInInfo),
TxInfo (..),
TxOut (TxOut),
TxOutRef (TxOutRef),
ValidatorHash (ValidatorHash),
Value,
)
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)
currencySymbol :: CurrencySymbol
currencySymbol = "deadbeef"
mkTxInfo :: Value -> [TxOut] -> TxInfo
mkTxInfo mint outs =
TxInfo
{ txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
, txInfoOutputs = []
, txInfoFee = Value.singleton "" "" 1000
, txInfoMint = mint
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = []
, txInfoData = []
, txInfoId = ""
}
singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
singleAuthorityTokenBurnedTest mint outs =
let actual :: ClosedTerm PBool
actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
s :: ClosedTerm POpaque
s =
pif
actual
(popaque (pconstant ()))
perror
in compile s
tests :: [TestTree]
tests =
[ -- This is better suited for plutarch-test
testGroup
"singleAuthorityTokenBurned"
[ scriptSucceeds
"Correct simple"
( singleAuthorityTokenBurnedTest
( Value.singleton currencySymbol "deadbeef" (-1)
<> Value.singleton "aa" "USDC" 100_000
)
[ TxOut
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
(Value.singleton currencySymbol "deadbeef" 1)
Nothing
]
)
, scriptSucceeds
"Correct many inputs"
( singleAuthorityTokenBurnedTest
( Value.singleton currencySymbol "deadbeef" (-1)
<> Value.singleton "aa" "USDC" 100_000
)
[ TxOut
(Address (PubKeyCredential "") Nothing)
(Value.singleton "aaabcc" "hello-token" 1)
Nothing
, TxOut
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
(Value.singleton currencySymbol "deadbeef" 1)
Nothing
, TxOut
(Address (PubKeyCredential "") Nothing)
(Value.singleton "" "" 1_000_000_000)
Nothing
]
)
, scriptFails
"Incorrect no burn"
( singleAuthorityTokenBurnedTest
( Value.Value AssocMap.empty
)
[]
)
, scriptFails
"Incorrect no GAT burn"
( singleAuthorityTokenBurnedTest
( Value.singleton "aabbcc" "not a GAT!" (-100)
)
[]
)
, scriptFails
"Incorrect script mismatch"
( singleAuthorityTokenBurnedTest
( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
)
[ TxOut
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
(Value.singleton currencySymbol "i'm not deadbeef!" 1)
Nothing
]
)
, scriptFails
"Incorrect spent from PK"
( singleAuthorityTokenBurnedTest
( Value.singleton currencySymbol "doesn't matter" (-1)
)
[ TxOut
(Address (PubKeyCredential "") Nothing)
(Value.singleton currencySymbol "doesn't matter" 1)
Nothing
]
)
, scriptFails
"Incorrect two GATs"
( singleAuthorityTokenBurnedTest
( Value.singleton currencySymbol "deadbeef" (-2)
<> Value.singleton "aa" "USDC" 100_000
)
[ TxOut
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
(Value.singleton currencySymbol "deadbeef" 2)
Nothing
]
)
]
]

168
agora-test/Spec/Effect/TreasuryWithdrawal.hs Normal file
View file

@ -0,0 +1,168 @@
{- |
Module : Spec.Effect.TreasuryWithdrawalEffect
Maintainer : seungheon.ooh@gmail.com
Description: Sample based testing for Treasury Withdrawal Effect
This module tests the Treasury Withdrawal Effect.
-}
module Spec.Effect.TreasuryWithdrawal (tests) where
import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
treasuryWithdrawalValidator,
)
import Plutus.V1.Ledger.Value qualified as Value
import Spec.Sample.Effect.TreasuryWithdrawal (
buildReceiversOutputFromDatum,
buildScriptContext,
currSymbol,
inputCollateral,
inputGAT,
inputTreasury,
inputUser,
outputTreasury,
outputUser,
treasuries,
users,
)
import Spec.Util (effectFailsWith, effectSucceedsWith)
import Test.Tasty (TestTree, testGroup)
tests :: [TestTree]
tests =
[ testGroup
"effect"
[ effectSucceedsWith
"Simple"
(treasuryWithdrawalValidator currSymbol)
datum1
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 1 (asset1 10)
]
$ outputTreasury 1 (asset1 7) :
buildReceiversOutputFromDatum datum1
)
, effectSucceedsWith
"Simple with multiple treasuries "
(treasuryWithdrawalValidator currSymbol)
datum1
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 1 (asset1 10)
, inputTreasury 2 (asset1 100)
, inputTreasury 3 (asset1 500)
]
$ [ outputTreasury 1 (asset1 7)
, outputTreasury 2 (asset1 100)
, outputTreasury 3 (asset1 500)
]
++ buildReceiversOutputFromDatum datum1
)
, effectSucceedsWith
"Mixed Assets"
(treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 1 (asset1 20)
, inputTreasury 2 (asset2 20)
]
$ [ outputTreasury 1 (asset1 13)
, outputTreasury 2 (asset2 14)
]
++ buildReceiversOutputFromDatum datum2
)
, effectFailsWith
"Pay to uknown 3rd party"
(treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 1 (asset1 20)
, inputTreasury 2 (asset2 20)
]
$ [ outputUser 100 (asset1 2)
, outputTreasury 1 (asset1 11)
, outputTreasury 2 (asset2 14)
]
++ buildReceiversOutputFromDatum datum2
)
, effectFailsWith
"Missing receiver"
(treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 1 (asset1 20)
, inputTreasury 2 (asset2 20)
]
$ [ outputTreasury 1 (asset1 13)
, outputTreasury 2 (asset2 14)
]
++ drop 1 (buildReceiversOutputFromDatum datum2)
)
, effectFailsWith
"Unauthorized treasury"
(treasuryWithdrawalValidator currSymbol)
datum3
( buildScriptContext
[ inputGAT
, inputCollateral 10
, inputTreasury 999 (asset1 20)
]
$ outputTreasury 999 (asset1 17) :
buildReceiversOutputFromDatum datum3
)
, effectFailsWith
"Prevent transactions besides the withdrawal"
(treasuryWithdrawalValidator currSymbol)
datum3
( buildScriptContext
[ inputGAT
, inputTreasury 1 (asset1 20)
, inputTreasury 999 (asset1 20)
, inputUser 99 (asset2 100)
]
$ [ outputTreasury 1 (asset1 17)
, outputUser 100 (asset2 100)
]
++ buildReceiversOutputFromDatum datum3
)
]
]
where
asset1 = Value.singleton "abbc12" "OrangeBottle"
asset2 = Value.singleton "abbc12" "19721121"
datum1 =
TreasuryWithdrawalDatum
[ (head users, asset1 1)
, (users !! 1, asset1 1)
, (users !! 2, asset1 1)
]
[ treasuries !! 1
, treasuries !! 2
, treasuries !! 3
]
datum2 =
TreasuryWithdrawalDatum
[ (head users, asset1 4 <> asset2 5)
, (users !! 1, asset1 2 <> asset2 1)
, (users !! 2, asset1 1)
]
[ head treasuries
, treasuries !! 1
, treasuries !! 2
]
datum3 =
TreasuryWithdrawalDatum
[ (head users, asset1 1)
, (users !! 1, asset1 1)
, (users !! 2, asset1 1)
]
[treasuries !! 1]

399
agora-test/Spec/Model/Treasury.hs
View file

@ -1,399 +0,0 @@
{-# OPTIONS_GHC -Wwarn #-}
{- |
Module: Spec.Model.Treasury
Description: `apropos-tx` tests for Treasury validator.
Maintainer: jack@mlabs.city
This module contains `apropos-tx` tests for ensuring that
the `Agora.Treasury` validator acts as desired. Notes on desired
behaviour and invluded in this description.
A Treasury transaction should pass if:
1. A GAT is burned.
2. All GATs are valid.
3. The script purpose is Minting.
If either of these things do /not/ hold, then the transaction
should fail.
-}
module Spec.Model.Treasury (
plutarchTests,
genTests,
) where
import Agora.Treasury (
PTreasuryDatum (PTreasuryDatum),
PTreasuryRedeemer (PAlterTreasuryParams),
treasuryValidator,
)
import Apropos (
Apropos (Apropos),
Contract,
Enumerable (enumerated),
Formula (
All,
Not,
Some,
Var,
Yes,
(:&&:),
(:||:)
),
Gen,
HasLogicalModel (satisfiesProperty),
HasParameterisedGenerator (parameterisedGenerator),
HasPermutationGenerator (buildGen, generators),
LogicalModel (logic),
Morphism (Morphism, contract, match, morphism, name),
add,
choice,
remove,
runGeneratorTestsWhere,
(:+),
)
import Apropos.Gen.Contexts (scriptContext, txInInfo, txOutRef)
import Apropos.Gen.Credential (stakingCredential)
import Apropos.Gen.DCert (dCert)
import Apropos.Gen.Value (currencySymbol)
import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
import Data.Bifunctor (Bifunctor (first))
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import Plutarch.Api.V1 (PCurrencySymbol, PScriptContext)
import Plutarch.Builtin (pforgetData)
import Plutus.V1.Ledger.Address (Address (addressCredential))
import Plutus.V1.Ledger.Contexts (
ScriptContext (scriptContextPurpose, scriptContextTxInfo),
ScriptPurpose (Certifying, Minting, Rewarding, Spending),
TxInInfo (txInInfoResolved),
TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
TxOut (txOutAddress, txOutValue),
)
import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
import Plutus.V1.Ledger.Scripts (Script, ValidatorHash (ValidatorHash))
import Plutus.V1.Ledger.Value (
CurrencySymbol (CurrencySymbol),
TokenName (TokenName, unTokenName),
Value (Value, getValue),
)
import Plutus.V1.Ledger.Value qualified as Value (unionWith)
import PlutusTx.AssocMap (Map, elems, fromList, keys, singleton, toList, unionWith)
import PlutusTx.AssocMap qualified as AssocMap (delete, insert, lookup)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (fromGroup)
data TreasuryTxProp
= GATIsBurned
| AllGATsValid
| ScriptPurposeIsMinting
deriving stock (Show, Eq, Ord, Enum, Bounded)
instance LogicalModel TreasuryTxProp where
logic :: Formula TreasuryTxProp
logic = Yes
data TreasuryTxModel = TreasuryTxModel
{ gatCs :: CurrencySymbol
, ctx :: ScriptContext
}
deriving stock (Show)
instance Enumerable TreasuryTxProp where
enumerated :: [TreasuryTxProp]
enumerated = [minBound .. maxBound]
isMinting :: ScriptPurpose -> Bool
isMinting (Minting _) = True
isMinting _ = False
authorityTokensValidIn :: CurrencySymbol -> TxOut -> Bool
authorityTokensValidIn cs out =
let add = out.txOutAddress :: Address
outValue = out.txOutValue :: Value
tokenMap :: Maybe (Map TokenName Integer)
tokenMap = AssocMap.lookup cs $ getValue outValue
cred = add.addressCredential :: Credential
validCred :: Map TokenName Integer -> Bool
validCred m = case cred of
PubKeyCredential _ -> False
ScriptCredential (ValidatorHash vh) ->
all (\tn -> vh == unTokenName tn) $ keys m
in maybe True validCred tokenMap
instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
satisfiesProperty prop model =
let purpose = model.ctx.scriptContextPurpose :: ScriptPurpose
txInfo = model.ctx.scriptContextTxInfo :: TxInfo
amountMinted = txInfo.txInfoMint :: Value
csValue :: Maybe (Map TokenName Integer)
csValue = AssocMap.lookup model.gatCs (getValue amountMinted)
csValueSum :: Integer
csValueSum = case csValue of
Nothing -> 0
Just m -> sum $ elems m
in case prop of
GATIsBurned -> csValueSum == -1
AllGATsValid ->
all
(authorityTokensValidIn model.gatCs . txInInfoResolved)
txInfo.txInfoInputs
ScriptPurposeIsMinting -> isMinting purpose
instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
parameterisedGenerator :: Set TreasuryTxProp -> Gen TreasuryTxModel
parameterisedGenerator = buildGen baseGen
where
baseGen :: Gen TreasuryTxModel
baseGen = do
cs <- currencySymbol
ctx <- scriptContext
return $ TreasuryTxModel cs ctx
{- | Updates the `Integer` and `TokenName` for a given
`CurrencySymbol` for a given value.
-}
replaceValue ::
-- | The value whose entry to update.
Value ->
-- | The currency symbol of the entry to update.
CurrencySymbol ->
-- | The token name of the entry to place in the new value.
TokenName ->
-- | The number of tokens to place in the new value.
Integer ->
-- | The updated value.
Value
replaceValue (Value v) cs tn n = Value $ unionWith (\_ x -> x) v v'
where
v' :: Map CurrencySymbol (Map TokenName Integer)
v' = singleton cs $ singleton tn n
kmap :: (k -> k') -> Map k v -> Map k' v
kmap g = fromList . fmap (first g) . toList
fixTokenNames :: CurrencySymbol -> TxInInfo -> TxInInfo
fixTokenNames cs inf =
let cred = inf.txInInfoResolved.txOutAddress.addressCredential
Value val = inf.txInInfoResolved.txOutValue
in case cred of
PubKeyCredential _ ->
let newVal = Value $ AssocMap.delete cs val
in inf {txInInfoResolved = inf.txInInfoResolved {txOutValue = newVal}}
ScriptCredential (ValidatorHash bs) ->
case AssocMap.lookup cs val of
Nothing -> inf
Just m ->
let tn :: TokenName = TokenName bs
m' = kmap (\_ -> tn) m
v' = Value $ AssocMap.insert cs m' val
in inf
{ txInInfoResolved =
inf.txInInfoResolved
{ txOutValue = v'
}
}
instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
generators :: [Morphism TreasuryTxProp TreasuryTxModel]
generators =
[ Morphism
{ name = "Ensure GAT is burned"
, match = Not $ Var GATIsBurned
, contract = add GATIsBurned
, morphism = \m ->
let ctx' = m.ctx
txInfo = ctx'.scriptContextTxInfo
mint = txInfo.txInfoMint
newMint = replaceValue mint m.gatCs "gat" (-1)
in return
m
{ ctx =
ctx'
{ scriptContextTxInfo =
txInfo
{ txInfoMint = newMint
}
}
}
}
, Morphism
{ name = "Ensure all GATs are valid"
, match = Not $ Var AllGATsValid
, contract = add AllGATsValid
, {- For every GAT to be considered "valid", their
`TokenName`s have to be equal to the address
of their script. To represent this as a `Morphism`:
- FOR every UTXO input in the transaction:
- FOR every value in the input:
- IF the currency symbol matches the recognised
GAT currency symbol:
- THEN: set the `TokenName` to be equal to
the UTXO's address.
- ELSE: ignore it.
-}
morphism = \m ->
let ctx' = m.ctx
txInfo = ctx'.scriptContextTxInfo
infoInputs :: [TxInInfo] = txInfo.txInfoInputs
in return $
m
{ ctx =
ctx'
{ scriptContextTxInfo =
txInfo
{ txInfoInputs =
fixTokenNames m.gatCs <$> infoInputs
}
}
}
}
, Morphism
{ name = "Ensure script purpose is minting"
, match = Not $ Var ScriptPurposeIsMinting
, contract = add ScriptPurposeIsMinting
, morphism = \m ->
return
m
{ ctx =
m.ctx
{ scriptContextPurpose = Minting m.gatCs
}
}
}
, Morphism
{ name = "Ensure GAT is not burned"
, match = Var GATIsBurned
, contract = remove GATIsBurned
, morphism = \m ->
let ctx' = m.ctx
txInfo = ctx'.scriptContextTxInfo
mint = txInfo.txInfoMint
newMint = replaceValue mint m.gatCs "gat" 0
in return
m
{ ctx =
ctx'
{ scriptContextTxInfo =
txInfo
{ txInfoMint = newMint
}
}
}
}
, Morphism
{ name = "Ensure ScriptPurpose is not Minting"
, match = Var ScriptPurposeIsMinting
, contract = remove ScriptPurposeIsMinting
, morphism = \m -> do
newPurpose <-
choice
[ Spending <$> txOutRef
, Rewarding <$> stakingCredential
, Certifying <$> dCert
]
return m {ctx = m.ctx {scriptContextPurpose = newPurpose}}
}
, Morphism
{ name = "Ensure not all GATs are valid."
, match = Var AllGATsValid
, contract = remove AllGATsValid
, morphism = \m -> do
dummyInp <- txInInfo
let ctx' = m.ctx
txInfo = ctx'.scriptContextTxInfo
inputs = txInfo.txInfoInputs
firstIn = listToMaybe inputs
inp = case firstIn of
Nothing -> dummyInp
Just inp' -> inp'
inVal = inp.txInInfoResolved.txOutValue
invalidGat =
Value $
singleton m.gatCs $
singleton "notAnAddress" (-1)
newVal = Value.unionWith (+) inVal invalidGat
newIn =
inp
{ txInInfoResolved =
inp.txInInfoResolved
{ txOutValue = newVal
}
}
newInputs = newIn : drop 1 inputs
return
m
{ ctx =
ctx'
{ scriptContextTxInfo =
txInfo
{ txInfoInputs = newInputs
}
}
}
}
]
instance ScriptModel TreasuryTxProp TreasuryTxModel where
expect :: (TreasuryTxModel :+ TreasuryTxProp) -> Formula TreasuryTxProp
expect _ =
Var GATIsBurned
:&&: Var AllGATsValid
:&&: Var ScriptPurposeIsMinting
script :: (TreasuryTxModel :+ TreasuryTxProp) -> TreasuryTxModel -> Script
script _ m = compile result
where
result :: Term s POpaque
result =
treasuryValidator cs
# pforgetData (pdata d)
# pforgetData (pdata r)
# ctx
cs :: CurrencySymbol
cs = m.gatCs
d :: Term s PTreasuryDatum
d = pcon $ PTreasuryDatum fields
where
adaStateThread :: Term _ PCurrencySymbol
adaStateThread = pconstant $ CurrencySymbol ""
fields :: Term _ (PDataRecord '["stateThread" ':= PCurrencySymbol])
fields = pdcons # pdata adaStateThread # pdnil
r :: Term s PTreasuryRedeemer
r = pcon $ PAlterTreasuryParams pdnil
ctx :: Term s PScriptContext
ctx = pconstant m.ctx
genTests :: TestTree
genTests =
testGroup "genTests" $
fromGroup
<$> [ runGeneratorTestsWhere
(Apropos :: TreasuryTxModel :+ TreasuryTxProp)
"Generator"
Yes
]
plutarchTests :: TestTree
plutarchTests =
testGroup "plutarchTests" $
fromGroup
<$> [ runScriptTestsWhere
(Apropos :: TreasuryTxModel :+ TreasuryTxProp)
"ScriptValid"
Yes
]

91
agora-test/Spec/Proposal.hs Normal file
View file

@ -0,0 +1,91 @@
{-# LANGUAGE QuasiQuotes #-}
{- |
Module : Spec.Proposal
Maintainer : emi@haskell.fyi
Description: Tests for Proposal policy and validator
Tests for Proposal policy and validator
-}
module Spec.Proposal (tests) where
--------------------------------------------------------------------------------
import Agora.Proposal (
ProposalDatum (ProposalDatum),
ProposalId (ProposalId),
ProposalRedeemer (Cosign),
ProposalStatus (Draft),
ResultTag (ResultTag),
cosigners,
effects,
emptyVotesFor,
proposalId,
status,
thresholds,
votes,
)
import Agora.Proposal.Scripts (
proposalPolicy,
proposalValidator,
)
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake))
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 Test.Tasty (TestTree, testGroup)
--------------------------------------------------------------------------------
-- | Stake tests.
tests :: [TestTree]
tests =
[ testGroup
"policy"
[ policySucceedsWith
"proposalCreation"
(proposalPolicy Shared.proposal)
()
Proposal.proposalCreation
]
, testGroup
"validator"
[ testGroup
"cosignature"
[ validatorSucceedsWith
"proposal"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, [])
, (ResultTag 1, [])
]
, status = Draft
, cosigners = [signer]
, thresholds = Shared.defaultProposalThresholds
, votes =
emptyVotesFor $
AssocMap.fromList
[ (ResultTag 0, [])
, (ResultTag 1, [])
]
}
)
(Cosign [signer2])
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef))
, validatorSucceedsWith
"stake"
(stakeValidator Shared.stake)
(StakeDatum (Tagged 50_000_000) signer2 [])
WitnessStake
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
]
]
]

172
agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs Normal file
View file

@ -0,0 +1,172 @@
{- |
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)
}

234
agora-test/Spec/Sample/Proposal.hs Normal file
View file

@ -0,0 +1,234 @@
{- |
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"
}

133
agora-test/Spec/Sample/Shared.hs Normal file
View file

@ -0,0 +1,133 @@
{- |
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,
-- * Components
-- ** Stake
stake,
stakeSymbol,
stakeValidatorHash,
stakeAddress,
-- ** Governor
governor,
govPolicy,
govValidator,
govSymbol,
-- ** Proposal
defaultProposalThresholds,
proposal,
proposalPolicySymbol,
proposalValidatorHash,
proposalValidatorAddress,
) where
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 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.Scripts (Validator, ValidatorHash)
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
}

62
agora-test/Spec/Sample/Stake.hs
View file

@ -7,8 +7,7 @@ This module tests primarily the happy path for Stake creation
-}
module Spec.Sample.Stake (
stake,
policy,
policySymbol,
stakeSymbol,
validatorHashTN,
signer,
@ -22,19 +21,14 @@ module Spec.Sample.Stake (
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
import Plutus.V1.Ledger.Api (
Address (Address),
Credential (ScriptCredential),
CurrencySymbol,
Datum (Datum),
DatumHash (DatumHash),
MintingPolicy (..),
PubKeyHash,
ScriptContext (..),
ScriptPurpose (..),
ToData (toBuiltinData),
@ -45,55 +39,28 @@ import Plutus.V1.Ledger.Api (
)
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
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)
--------------------------------------------------------------------------------
-- | 'Stake' parameters for 'LQ'.
stake :: Stake
stake =
Stake
{ gtClassRef =
Tagged
( AssetClass
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
, "LQ"
)
)
}
-- | 'Stake' policy instance.
policy :: MintingPolicy
policy = mkMintingPolicy (stakePolicy stake)
policySymbol :: CurrencySymbol
policySymbol = mintingPolicySymbol policy
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-- | 'Stake' validator instance.
validator :: Validator
validator = mkValidator (stakeValidator stake)
-- | 'TokenName' that represents the hash of the 'Stake' validator.
validatorHashTN :: TokenName
validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
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 policySymbol validatorHashTN 1 -- Stake ST
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
datum :: Datum
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
in ScriptContext
@ -102,7 +69,7 @@ stakeCreation =
{ txInfoInputs = []
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
, txOutDatumHash = Just (DatumHash "")
}
@ -116,7 +83,7 @@ stakeCreation =
, txInfoData = [("", datum)]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
}
, scriptContextPurpose = Minting policySymbol
, scriptContextPurpose = Minting stakeSymbol
}
-- | This ScriptContext should fail because the datum has too much GT.
@ -126,7 +93,7 @@ stakeCreationWrongDatum =
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
in ScriptContext
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
, scriptContextPurpose = Minting policySymbol
, scriptContextPurpose = Minting stakeSymbol
}
-- | This ScriptContext should fail because the datum has too much GT.
@ -137,7 +104,7 @@ stakeCreationUnsigned =
stakeCreation.scriptContextTxInfo
{ txInfoSignatories = []
}
, scriptContextPurpose = Minting policySymbol
, scriptContextPurpose = Minting stakeSymbol
}
--------------------------------------------------------------------------------
@ -153,7 +120,7 @@ data DepositWithdrawExample = DepositWithdrawExample
-- | Create a ScriptContext that deposits or withdraws, given the config for it.
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
stakeDepositWithdraw config =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
stakeBefore :: StakeDatum
stakeBefore = StakeDatum config.startAmount signer []
@ -166,7 +133,7 @@ stakeDepositWithdraw config =
[ TxInInfo
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue =
st
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
@ -175,10 +142,9 @@ stakeDepositWithdraw config =
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue =
st
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]

14
agora-test/Spec/Stake.hs
View file

@ -19,7 +19,8 @@ import Test.Tasty (TestTree, testGroup)
--------------------------------------------------------------------------------
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw))
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
--------------------------------------------------------------------------------
@ -36,20 +37,23 @@ tests =
"policy"
[ policySucceedsWith
"stakeCreation"
(stakePolicy Stake.stake)
(stakePolicy Stake.stake.gtClassRef)
()
Stake.stakeCreation
, policyFailsWith
"stakeCreationWrongDatum"
(stakePolicy Stake.stake)
(stakePolicy Stake.stake.gtClassRef)
()
Stake.stakeCreationWrongDatum
, policyFailsWith
"stakeCreationUnsigned"
(stakePolicy Stake.stake)
(stakePolicy Stake.stake.gtClassRef)
()
Stake.stakeCreationUnsigned
, validatorSucceedsWith
]
, testGroup
"validator"
[ validatorSucceedsWith
"stakeDepositWithdraw deposit"
(stakeValidator Stake.stake)
(toDatum $ StakeDatum 100_000 signer [])

34
agora-test/Spec/Util.hs
View file

@ -13,6 +13,8 @@ module Spec.Util (
policyFailsWith,
validatorSucceedsWith,
validatorFailsWith,
effectSucceedsWith,
effectFailsWith,
-- * Plutus-land utils
datumHash,
@ -98,10 +100,10 @@ validatorSucceedsWith ::
PLifted redeemer ->
ScriptContext ->
TestTree
validatorSucceedsWith tag policy datum redeemer scriptContext =
validatorSucceedsWith tag validator datum redeemer scriptContext =
scriptSucceeds tag $
compile
( policy
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
@ -120,15 +122,39 @@ validatorFailsWith ::
PLifted redeemer ->
ScriptContext ->
TestTree
validatorFailsWith tag policy datum redeemer scriptContext =
validatorFailsWith tag validator datum redeemer scriptContext =
scriptFails tag $
compile
( policy
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
-- | Check that a validator script succeeds, given a name and arguments.
effectSucceedsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
) =>
String ->
ClosedTerm PValidator ->
PLifted datum ->
ScriptContext ->
TestTree
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
-- | Check that a validator script fails, given a name and arguments.
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