diff --git a/agora-specs/Sample/Stake/Create.hs b/agora-specs/Sample/Stake/Create.hs new file mode 100644 index 0000000..40266df --- /dev/null +++ b/agora-specs/Sample/Stake/Create.hs @@ -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] + } + } diff --git a/agora-specs/Spec/Stake.hs b/agora-specs/Spec/Stake.hs index 7e62929..3f7cf22 100644 --- a/agora-specs/Spec/Stake.hs +++ b/agora-specs/Spec/Stake.hs @@ -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 () diff --git a/agora.cabal b/agora.cabal index a1961b3..26855cd 100644 --- a/agora.cabal +++ b/agora.cabal @@ -204,6 +204,7 @@ library agora-specs Sample.Proposal.Vote Sample.Shared Sample.Stake + Sample.Stake.Create Sample.Stake.SetDelegate Sample.Treasury Spec.AuthorityToken diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 6aae378..af37bce 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -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 ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index be892d7..6227265 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -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