tests for creating stakes
This commit is contained in:
Hongrui Fang
parent
1b4531f3ee
commit
eba25adbf7
5 changed files with 356 additions and 19 deletions
260
agora-specs/Sample/Stake/Create.hs
Normal file
260
agora-specs/Sample/Stake/Create.hs
Normal file
|
|
@ -0,0 +1,260 @@
|
|||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
|
||||
module Sample.Stake.Create (
|
||||
StakeDatumWrapper (..),
|
||||
Parameters (..),
|
||||
create,
|
||||
mkTestCase,
|
||||
ownerIsPubKeyTotallyValid,
|
||||
ownerIsScriptTotallyValid,
|
||||
createMoreThanOneStake,
|
||||
spendStake,
|
||||
unexpectedStakedAmount,
|
||||
noStakeDatum,
|
||||
malformedStakeDatum,
|
||||
notAuthorizedByOwner,
|
||||
setDelegatee,
|
||||
alreadyHasLocks,
|
||||
) where
|
||||
|
||||
import Agora.Governor (Governor (gtClassRef))
|
||||
import Agora.Proposal (ProposalId (ProposalId))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (ProposalLock (Created), StakeDatum (..))
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Semigroup (stimesMonoid)
|
||||
import Data.Tagged (Tagged)
|
||||
import Plutarch.Context (
|
||||
input,
|
||||
mint,
|
||||
normalizeValue,
|
||||
output,
|
||||
pubKey,
|
||||
script,
|
||||
signedWith,
|
||||
withDatum,
|
||||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (
|
||||
PubKeyCredential,
|
||||
ScriptCredential
|
||||
),
|
||||
)
|
||||
import Sample.Shared (
|
||||
governor,
|
||||
signer,
|
||||
signer2,
|
||||
stakePolicy,
|
||||
stakeSymbol,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Test.Specification (SpecificationTree, testPolicy)
|
||||
import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
|
||||
|
||||
data StakeDatumWrapper
|
||||
= forall (b :: Type) (p :: S -> Type).
|
||||
(PUnsafeLiftDecl p, PLifted p ~ b, PIsData p) =>
|
||||
StakeDatumWrapper b
|
||||
|
||||
data Parameters = Parameters
|
||||
{ numSSTMinted :: Integer
|
||||
, invalidSSTName :: Bool
|
||||
, stakeAtInput :: Bool
|
||||
, numGTsInValue :: Tagged GTTag Integer
|
||||
, stakeDatum :: Maybe StakeDatumWrapper
|
||||
, authorizedBy :: Maybe Credential
|
||||
}
|
||||
|
||||
create :: forall b. CombinableBuilder b => Parameters -> b
|
||||
create ps@Parameters {stakeDatum} =
|
||||
let perStakeGTs =
|
||||
assetClassValue
|
||||
governor.gtClassRef
|
||||
ps.numGTsInValue
|
||||
|
||||
gtValue =
|
||||
stimesMonoid ps.numSSTMinted perStakeGTs
|
||||
|
||||
gtInputBuilder =
|
||||
mconcat
|
||||
[ input $
|
||||
mconcat
|
||||
[ pubKey signer
|
||||
, withValue $ normalizeValue gtValue
|
||||
]
|
||||
]
|
||||
|
||||
---
|
||||
|
||||
sstName =
|
||||
if ps.invalidSSTName
|
||||
then "114514"
|
||||
else validatorHashToTokenName stakeValidatorHash
|
||||
|
||||
sst = Value.singleton stakeSymbol sstName 1
|
||||
|
||||
withStakeDatum =
|
||||
maybe
|
||||
mempty
|
||||
(\(StakeDatumWrapper stakeDatum) -> withDatum stakeDatum)
|
||||
stakeDatum
|
||||
|
||||
stakeBuilder =
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue $ normalizeValue $ sst <> perStakeGTs
|
||||
, withStakeDatum
|
||||
]
|
||||
|
||||
stakeInputBuilder =
|
||||
if ps.stakeAtInput
|
||||
then input stakeBuilder
|
||||
else mempty
|
||||
|
||||
stakeOutputBuilder =
|
||||
stimesMonoid ps.numSSTMinted $
|
||||
output stakeBuilder
|
||||
|
||||
---
|
||||
|
||||
withAuthorization =
|
||||
maybe
|
||||
mempty
|
||||
( \case
|
||||
PubKeyCredential pkh -> signedWith pkh
|
||||
ScriptCredential val -> input $ script val
|
||||
)
|
||||
ps.authorizedBy
|
||||
|
||||
---
|
||||
|
||||
mintSSTs = mint $ stimesMonoid ps.numSSTMinted sst
|
||||
in mconcat
|
||||
[ gtInputBuilder
|
||||
, stakeInputBuilder
|
||||
, stakeOutputBuilder
|
||||
, withAuthorization
|
||||
, mintSSTs
|
||||
]
|
||||
|
||||
mkTestCase :: String -> Parameters -> Bool -> SpecificationTree
|
||||
mkTestCase name ps val = stake
|
||||
where
|
||||
mint = mkMinting create ps
|
||||
|
||||
stake =
|
||||
testPolicy
|
||||
val
|
||||
name
|
||||
stakePolicy
|
||||
()
|
||||
(mint stakeSymbol)
|
||||
|
||||
mkTotallyValid :: Integer -> Credential -> Parameters
|
||||
mkTotallyValid gts owner =
|
||||
Parameters
|
||||
{ numSSTMinted = 1
|
||||
, invalidSSTName = False
|
||||
, numGTsInValue = fromInteger gts
|
||||
, stakeAtInput = False
|
||||
, stakeDatum =
|
||||
Just $
|
||||
StakeDatumWrapper $
|
||||
StakeDatum
|
||||
{ stakedAmount = fromInteger gts
|
||||
, owner = owner
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = []
|
||||
}
|
||||
, authorizedBy = Just owner
|
||||
}
|
||||
|
||||
ownerIsPubKeyTotallyValid :: Parameters
|
||||
ownerIsPubKeyTotallyValid = mkTotallyValid 114514 (PubKeyCredential signer)
|
||||
|
||||
ownerIsScriptTotallyValid :: Parameters
|
||||
ownerIsScriptTotallyValid =
|
||||
mkTotallyValid
|
||||
114514
|
||||
( ScriptCredential $
|
||||
head validatorHashes
|
||||
)
|
||||
|
||||
createMoreThanOneStake :: Parameters
|
||||
createMoreThanOneStake =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ numSSTMinted = 5
|
||||
}
|
||||
|
||||
spendStake :: Parameters
|
||||
spendStake =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ stakeAtInput = True
|
||||
}
|
||||
|
||||
unexpectedStakedAmount :: Parameters
|
||||
unexpectedStakedAmount =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ numGTsInValue = 114514
|
||||
, stakeDatum =
|
||||
Just $
|
||||
StakeDatumWrapper $
|
||||
StakeDatum
|
||||
{ stakedAmount = 1919810
|
||||
, owner = PubKeyCredential signer
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = []
|
||||
}
|
||||
}
|
||||
|
||||
noStakeDatum :: Parameters
|
||||
noStakeDatum =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ stakeDatum = Nothing
|
||||
}
|
||||
|
||||
malformedStakeDatum :: Parameters
|
||||
malformedStakeDatum =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ stakeDatum = Just $ StakeDatumWrapper (1 :: Integer)
|
||||
}
|
||||
|
||||
notAuthorizedByOwner :: Parameters
|
||||
notAuthorizedByOwner =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ authorizedBy = Nothing
|
||||
}
|
||||
|
||||
setDelegatee :: Parameters
|
||||
setDelegatee =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ numGTsInValue = 114514
|
||||
, stakeDatum =
|
||||
Just $
|
||||
StakeDatumWrapper $
|
||||
StakeDatum
|
||||
{ stakedAmount = 114514
|
||||
, owner = PubKeyCredential signer
|
||||
, delegatedTo = Just $ PubKeyCredential signer2
|
||||
, lockedBy = []
|
||||
}
|
||||
}
|
||||
|
||||
alreadyHasLocks :: Parameters
|
||||
alreadyHasLocks =
|
||||
ownerIsPubKeyTotallyValid
|
||||
{ numGTsInValue = 114514
|
||||
, stakeDatum =
|
||||
Just $
|
||||
StakeDatumWrapper $
|
||||
StakeDatum
|
||||
{ stakedAmount = 114514
|
||||
, owner = PubKeyCredential signer
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = [Created $ ProposalId 0]
|
||||
}
|
||||
}
|
||||
|
|
@ -13,8 +13,6 @@ import Agora.Stake (
|
|||
StakeDatum (StakeDatum),
|
||||
StakeRedeemer (DepositWithdraw),
|
||||
)
|
||||
import Data.Bool (Bool (..))
|
||||
import Data.Maybe (Maybe (..))
|
||||
import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
|
||||
import Sample.Shared (stakePolicy, stakeValidator)
|
||||
import Sample.Stake (
|
||||
|
|
@ -31,6 +29,7 @@ import Sample.Stake qualified as Stake (
|
|||
stakeCreationWrongDatum,
|
||||
stakeDepositWithdraw,
|
||||
)
|
||||
import Sample.Stake.Create qualified as Create
|
||||
import Sample.Stake.SetDelegate qualified as SetDelegate
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
|
|
@ -40,14 +39,62 @@ import Test.Specification (
|
|||
validatorFailsWith,
|
||||
validatorSucceedsWith,
|
||||
)
|
||||
import Prelude (Num (negate), ($))
|
||||
|
||||
-- | The SpecificationTree exported by this module.
|
||||
specs :: [SpecificationTree]
|
||||
specs =
|
||||
[ group
|
||||
"policy"
|
||||
[ policySucceedsWith
|
||||
[ group
|
||||
"create"
|
||||
[ group
|
||||
"valid"
|
||||
[ Create.mkTestCase
|
||||
"stake owner: pub key"
|
||||
Create.ownerIsPubKeyTotallyValid
|
||||
True
|
||||
, Create.mkTestCase
|
||||
"stake owner: script"
|
||||
Create.ownerIsScriptTotallyValid
|
||||
True
|
||||
]
|
||||
, group
|
||||
"invalid"
|
||||
[ Create.mkTestCase
|
||||
"mint more than one sst in one tx"
|
||||
Create.createMoreThanOneStake
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"spend stake while minting SST"
|
||||
Create.spendStake
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"wrong staked amount"
|
||||
Create.unexpectedStakedAmount
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"no stake datum"
|
||||
Create.noStakeDatum
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"bad stake datum"
|
||||
Create.malformedStakeDatum
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"not authorized by owner"
|
||||
Create.notAuthorizedByOwner
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"delegatee not empty"
|
||||
Create.setDelegatee
|
||||
False
|
||||
, Create.mkTestCase
|
||||
"have locks"
|
||||
Create.alreadyHasLocks
|
||||
False
|
||||
]
|
||||
]
|
||||
, policySucceedsWith
|
||||
"stakeCreation"
|
||||
stakePolicy
|
||||
()
|
||||
|
|
|
|||
|
|
@ -204,6 +204,7 @@ library agora-specs
|
|||
Sample.Proposal.Vote
|
||||
Sample.Shared
|
||||
Sample.Stake
|
||||
Sample.Stake.Create
|
||||
Sample.Stake.SetDelegate
|
||||
Sample.Treasury
|
||||
Spec.AuthorityToken
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ import Agora.Stake.Redeemers (
|
|||
ppermitVote,
|
||||
pretractVote,
|
||||
)
|
||||
import Agora.Utils (passert, pmapMaybe)
|
||||
import Agora.Utils (passert, pisDNothing, pmapMaybe)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
|
|
@ -73,7 +73,7 @@ import Plutarch.Extra.AssetClass (
|
|||
PAssetClassData,
|
||||
ptoScottEncoding,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import Plutarch.Extra.Maybe (
|
||||
|
|
@ -207,24 +207,31 @@ stakePolicy =
|
|||
# pfromData txInfoF.outputs
|
||||
|
||||
outputF <-
|
||||
pletFieldsC @'["value", "address", "datum"] scriptOutputWithStakeST
|
||||
datumF <-
|
||||
pletFieldsC @'["owner", "stakedAmount"] $
|
||||
pto $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum) # outputF.datum # txInfoF.datums
|
||||
pletFieldsC @'["value", "datum"]
|
||||
scriptOutputWithStakeST
|
||||
|
||||
let hasExpectedStake =
|
||||
ptraceIfFalse "Stake ouput has expected amount of stake token" $
|
||||
datumF <-
|
||||
pletAllC $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
pure $
|
||||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Stake ouput has expected amount of stake token" $
|
||||
passetClassValueOf # (ptoScottEncoding # gstClass) # outputF.value
|
||||
#== pto (pfromData datumF.stakedAmount)
|
||||
let ownerSignsTransaction =
|
||||
ptraceIfFalse "Stake Owner should sign the transaction" $
|
||||
, ptraceIfFalse "Stake Owner should sign the transaction" $
|
||||
pauthorizedBy
|
||||
# authorizationContext txInfoF
|
||||
# datumF.owner
|
||||
|
||||
pure $ hasExpectedStake #&& ownerSignsTransaction
|
||||
, ptraceIfFalse "Initial delegatee should set to nothing" $
|
||||
pisDNothing # datumF.delegatedTo
|
||||
, ptraceIfFalse "Initial locks should be empty" $
|
||||
pnull # pfromData datumF.lockedBy
|
||||
]
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
|
|
|
|||
|
|
@ -31,11 +31,13 @@ module Agora.Utils (
|
|||
pinsertUniqueBy,
|
||||
ptryFromRedeemer,
|
||||
passert,
|
||||
pisNothing,
|
||||
pisDNothing,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (KeyGuarantees (Unsorted), PPOSIXTime, PRedeemer, PTokenName, PValidatorHash)
|
||||
import Plutarch.Api.V1.AssocMap (PMap, plookup)
|
||||
import Plutarch.Api.V2 (PScriptHash, PScriptPurpose)
|
||||
import Plutarch.Api.V2 (PMaybeData (PDNothing), PScriptHash, PScriptPurpose)
|
||||
import Plutarch.Extra.Applicative (PApplicative (ppure))
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
|
||||
|
|
@ -385,3 +387,23 @@ passert ::
|
|||
Term s a ->
|
||||
Term s a
|
||||
passert msg cond x = pif cond x $ ptraceError msg
|
||||
|
||||
-- | @since 1.0.0
|
||||
pisNothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term s (PMaybe a :--> PBool)
|
||||
pisNothing = phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $ \case
|
||||
PNothing -> pconstant True
|
||||
_ -> pconstant False
|
||||
|
||||
-- | @since 1.0.0
|
||||
pisDNothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term s (PMaybeData a :--> PBool)
|
||||
pisDNothing = phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $ \case
|
||||
PDNothing _ -> pconstant True
|
||||
_ -> pconstant False
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue