From 044fba702bf0c199c556b112cd8de3304ddd5a09 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Thu, 20 Oct 2022 19:47:56 +0800 Subject: [PATCH] tests for destroying stakes --- agora-specs/Sample/Stake/Destroy.hs | 297 ++++++++++++++++++++++++++++ agora-specs/Spec/Stake.hs | 44 ++++- agora.cabal | 1 + 3 files changed, 341 insertions(+), 1 deletion(-) create mode 100644 agora-specs/Sample/Stake/Destroy.hs diff --git a/agora-specs/Sample/Stake/Destroy.hs b/agora-specs/Sample/Stake/Destroy.hs new file mode 100644 index 0000000..451c208 --- /dev/null +++ b/agora-specs/Sample/Stake/Destroy.hs @@ -0,0 +1,297 @@ +module Sample.Stake.Destroy ( + ParameterBundle (..), + StakeInputParameters (..), + StakeBurningParameters (..), + LeftOverStakeMode (..), + AuthorizedBy (..), + Validity (..), + destroy, + mkTestTree, + mkTotallyValid, + oneStake, + multipleStakes, + stealSST, + stealSST1, + stealSST3, + lockedStakes, + authorizedByDelegatee, + notAuthorized, +) where + +import Agora.Proposal (ProposalId (..)) +import Agora.Stake ( + ProposalLock (Created), + StakeDatum (..), + StakeRedeemer (Destroy), + ) +import Control.Exception (assert) +import Data.Maybe (catMaybes, fromJust) +import Data.Semigroup (stimesMonoid) +import Plutarch.Context ( + input, + mint, + normalizeValue, + output, + pubKey, + script, + signedWith, + withDatum, + withRedeemer, + withRef, + withValue, + ) +import Plutarch.Extra.AssetClass (assetClassValue) +import PlutusLedgerApi.V1 ( + Credential (PubKeyCredential), + TxOutRef (TxOutRef), + ) +import PlutusLedgerApi.V2 (PubKeyHash) +import Sample.Proposal.Shared (stakeTxRef) +import Sample.Shared ( + minAda, + signer2, + stakeAssetClass, + stakePolicy, + stakeSymbol, + stakeValidator, + stakeValidatorHash, + ) +import Test.Specification ( + SpecificationTree, + group, + testPolicy, + testValidator, + ) +import Test.Util (CombinableBuilder, mkMinting, mkSpending, pubKeyHashes) + +data ParameterBundle = ParameterBundle + { stakeInputParameters :: StakeInputParameters + , stakeBurningParameters :: StakeBurningParameters + , authorizedBy :: AuthorizedBy + } + +data StakeInputParameters = StakeInputParameters + { numInputs :: Int + , notUnlocked :: Bool + } + +data StakeBurningParameters = StakeBurningParameters + { numBurnt :: Int + , leftOverStakeMode :: Maybe LeftOverStakeMode + } + +data LeftOverStakeMode = OutputAsIs | CollectSSTInOneUTxO + +data AuthorizedBy = Owner | Delegatee | NotAuthorized + +data Validity = Validity + { forStakePolicy :: Maybe Bool + , forStakeValidator :: Bool + } + +-------------------------------------------------------------------------------- + +owner :: PubKeyHash +owner = pubKeyHashes !! 2 + +delegatee :: PubKeyHash +delegatee = pubKeyHashes !! 3 + +-------------------------------------------------------------------------------- + +mkStakeInputDatum :: StakeInputParameters -> StakeDatum +mkStakeInputDatum ps = + StakeDatum + { stakedAmount = 114514 + , owner = PubKeyCredential owner + , delegatedTo = Just $ PubKeyCredential delegatee + , lockedBy = [Created $ ProposalId 0 | ps.notUnlocked] + } + +mkStakeRef :: Int -> TxOutRef +mkStakeRef = TxOutRef stakeTxRef . fromIntegral + +stakeRedeemer :: StakeRedeemer +stakeRedeemer = Destroy + +-------------------------------------------------------------------------------- + +destroy :: forall b. CombinableBuilder b => ParameterBundle -> b +destroy ps = + let stakeInputDatum = mkStakeInputDatum ps.stakeInputParameters + + sst = assetClassValue stakeAssetClass 1 + + stakeUTxOTemplate = + mconcat + [ script stakeValidatorHash + , withDatum stakeInputDatum + , withValue $ normalizeValue $ sst <> minAda + ] + + stakeInputBuilder = + foldMap + ( \i -> + input $ + mconcat + [ stakeUTxOTemplate + , withRef $ mkStakeRef i + , withRedeemer stakeRedeemer + ] + ) + [1 .. ps.stakeInputParameters.numInputs] + + withSSTsBurnt = + mint $ + normalizeValue $ + assetClassValue stakeAssetClass $ + negate $ + fromIntegral ps.stakeBurningParameters.numBurnt + + --- + + leftOverStakes = + ps.stakeInputParameters.numInputs + - ps.stakeBurningParameters.numBurnt + + stealSSTs = + case fromJust ps.stakeBurningParameters.leftOverStakeMode of + OutputAsIs -> + foldMap output $ + replicate + leftOverStakes + stakeUTxOTemplate + CollectSSTInOneUTxO -> + output $ + mconcat + [ pubKey signer2 + , withValue $ stimesMonoid leftOverStakes sst + ] + + stakeOutputBuilder = + assert (leftOverStakes >= 0) $ + mconcat + [ withSSTsBurnt + , if leftOverStakes > 0 + then stealSSTs + else mempty + ] + + --- + + sigBuilder = case ps.authorizedBy of + Owner -> signedWith owner + Delegatee -> signedWith delegatee + NotAuthorized -> mempty + in mconcat + [ stakeInputBuilder + , stakeOutputBuilder + , sigBuilder + ] + +-------------------------------------------------------------------------------- + +mkTestTree :: + String -> + ParameterBundle -> + Validity -> + SpecificationTree +mkTestTree name pb val = group name $ catMaybes [validator, policy] + where + spend = mkSpending destroy pb + mint = mkMinting destroy pb + validator = + Just $ + testValidator + val.forStakeValidator + "stake validator" + stakeValidator + (mkStakeInputDatum pb.stakeInputParameters) + stakeRedeemer + (spend $ mkStakeRef 1) + + policy = case pb.stakeBurningParameters.numBurnt of + 0 -> Nothing + _ -> + Just $ + testPolicy + (fromJust val.forStakePolicy) + "stake policy" + stakePolicy + () + (mint stakeSymbol) + +-------------------------------------------------------------------------------- + +mkTotallyValid :: Int -> ParameterBundle +mkTotallyValid numStakes = + ParameterBundle + { stakeInputParameters = + StakeInputParameters + { numInputs = numStakes + , notUnlocked = False + } + , stakeBurningParameters = + StakeBurningParameters + { numBurnt = numStakes + , leftOverStakeMode = Nothing + } + , authorizedBy = Owner + } + +oneStake :: ParameterBundle +oneStake = mkTotallyValid 1 + +multipleStakes :: ParameterBundle +multipleStakes = mkTotallyValid 10 + +stealSST :: ParameterBundle +stealSST = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 1 + , leftOverStakeMode = Just CollectSSTInOneUTxO + } + } + +stealSST1 :: ParameterBundle +stealSST1 = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 0 + , leftOverStakeMode = Just CollectSSTInOneUTxO + } + } + +stealSST3 :: ParameterBundle +stealSST3 = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 1 + , leftOverStakeMode = Just OutputAsIs + } + } + +lockedStakes :: ParameterBundle +lockedStakes = + multipleStakes + { stakeInputParameters = + multipleStakes.stakeInputParameters + { notUnlocked = True + } + } + +authorizedByDelegatee :: ParameterBundle +authorizedByDelegatee = + multipleStakes + { authorizedBy = Delegatee + } + +notAuthorized :: ParameterBundle +notAuthorized = + multipleStakes + { authorizedBy = NotAuthorized + } diff --git a/agora-specs/Spec/Stake.hs b/agora-specs/Spec/Stake.hs index 1510dff..9445a73 100644 --- a/agora-specs/Spec/Stake.hs +++ b/agora-specs/Spec/Stake.hs @@ -27,6 +27,7 @@ import Sample.Stake qualified as Stake ( stakeDepositWithdraw, ) import Sample.Stake.Create qualified as Create +import Sample.Stake.Destroy qualified as Destroy import Sample.Stake.SetDelegate qualified as SetDelegate import Test.Specification ( SpecificationTree, @@ -92,7 +93,48 @@ specs = ] , group "validator" - [ validatorSucceedsWith + [ group + "destroy" + [ group + "legal" + [ Destroy.mkTestTree + "One stake" + Destroy.oneStake + (Destroy.Validity (Just True) True) + , Destroy.mkTestTree + "Multiple stake" + Destroy.multipleStakes + (Destroy.Validity (Just True) True) + ] + , group + "illegal" + [ Destroy.mkTestTree + "Destroy only one stake to steal SST" + Destroy.stealSST + (Destroy.Validity (Just False) False) + , Destroy.mkTestTree + "Destroy nothing to steal SST" + Destroy.stealSST1 + (Destroy.Validity Nothing False) + , Destroy.mkTestTree + "Steal SST" + Destroy.stealSST3 + (Destroy.Validity (Just False) False) + , Destroy.mkTestTree + "Destroy locked stakes" + Destroy.lockedStakes + (Destroy.Validity (Just False) False) + , Destroy.mkTestTree + "not authorized by owner" + Destroy.notAuthorized + (Destroy.Validity (Just True) False) + , Destroy.mkTestTree + "not authorized by owner" + Destroy.authorizedByDelegatee + (Destroy.Validity (Just True) False) + ] + ] + , validatorSucceedsWith "stakeDepositWithdraw deposit" stakeValidator (StakeDatum 100_000 (PubKeyCredential signer) Nothing []) diff --git a/agora.cabal b/agora.cabal index 26855cd..2ee025f 100644 --- a/agora.cabal +++ b/agora.cabal @@ -205,6 +205,7 @@ library agora-specs Sample.Shared Sample.Stake Sample.Stake.Create + Sample.Stake.Destroy Sample.Stake.SetDelegate Sample.Treasury Spec.AuthorityToken