Merge pull request #199 from Liqwid-Labs/connor/audit-fix

Tests for Staking Components

CHANGELOG.md

@@ -6,6 +6,11 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
 
 ### Modified
 
+- Fix a bug where `lockedBy` and `delegatedTo` fields of stake datums aren't checked
+  during the creation of stakes.
+
+  Included by [#199](https://github.com/Liqwid-Labs/agora/pull/199)
+
 - Fix several vulnerabilities and bugs found in staking components.
   
   Including:

agora-specs/Sample/Proposal/PrivilegeEscalate.hs

@@ -0,0 +1,242 @@
+module Sample.Proposal.PrivilegeEscalate (
+  Operation (..),
+  privilegeEscalate,
+  Validity (..),
+  mkTestTree,
+) where
+
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalId (ProposalId),
+  ProposalRedeemer (Unlock, Vote),
+  ProposalStatus (VotingReady),
+  ProposalVotes (ProposalVotes),
+  ResultTag (ResultTag),
+  emptyVotesFor,
+ )
+import Agora.Proposal.Time (
+  ProposalStartingTime (ProposalStartingTime),
+  ProposalTimingConfig (draftTime, votingTime),
+ )
+import Agora.SafeMoney (GTTag)
+import Agora.Stake (
+  ProposalLock (
+    Voted
+  ),
+  StakeDatum (..),
+  StakeRedeemer (PermitVote, RetractVotes),
+ )
+import Data.Default (Default (def))
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged, untag)
+import Plutarch.Context (
+  input,
+  normalizeValue,
+  output,
+  script,
+  signedWith,
+  timeRange,
+  withDatum,
+  withRedeemer,
+  withRef,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
+import PlutusLedgerApi.V2 (PubKeyHash, TxOutRef (TxOutRef))
+import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
+import Sample.Shared (
+  minAda,
+  proposalAssetClass,
+  proposalValidator,
+  proposalValidatorHash,
+  stakeAssetClass,
+  stakeValidator,
+  stakeValidatorHash,
+ )
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
+
+data Operation = Voting | RetractingVotes
+
+data Validity = Validity
+  { forStakeValidator :: Bool
+  , forProposalValidator :: Bool
+  }
+
+wrap :: forall x y. Operation -> (x -> x -> y) -> x -> x -> y
+wrap Voting = id
+wrap RetractingVotes = flip
+
+defStakeAmount :: Tagged GTTag Integer
+defStakeAmount = 100000
+
+defResultTag :: ResultTag
+defResultTag = ResultTag 0
+
+defProposalId :: ProposalId
+defProposalId = ProposalId 0
+
+mkProposalInputOutputDatum :: Operation -> (ProposalDatum, ProposalDatum)
+mkProposalInputOutputDatum op =
+  let effects = StrictMap.singleton defResultTag StrictMap.empty
+
+      proposal =
+        ProposalDatum
+          { proposalId = defProposalId
+          , effects = effects
+          , status = VotingReady
+          , cosigners = [] -- doesn't matter
+          , thresholds = def
+          , votes = emptyVotesFor effects
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 0
+          }
+
+      proposalWithVotes =
+        proposal
+          { votes =
+              ProposalVotes $
+                StrictMap.singleton defResultTag (untag defStakeAmount)
+          }
+   in wrap op (,) proposal proposalWithVotes
+
+mkProposalRedeemer :: Operation -> ProposalRedeemer
+mkProposalRedeemer op = wrap op const (Vote defResultTag) Unlock
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef proposalTxRef 1
+
+attacker :: PubKeyHash
+attacker = head pubKeyHashes
+
+mkStakeInputOutputDatums :: Operation -> ([StakeDatum], [StakeDatum])
+mkStakeInputOutputDatums op =
+  let delegatee = pubKeyHashes !! 1
+
+      firstStake =
+        StakeDatum
+          { stakedAmount = defStakeAmount
+          , owner = PubKeyCredential attacker
+          , delegatedTo = Just $ PubKeyCredential delegatee
+          , lockedBy = []
+          }
+
+      otherStakes =
+        (\pkh -> firstStake {owner = PubKeyCredential pkh})
+          <$> drop 2 pubKeyHashes
+
+      allStakes = take 10 $ firstStake : otherStakes
+
+      stakeWithLock =
+        (\stake -> stake {lockedBy = [Voted defProposalId defResultTag]})
+          <$> allStakes
+   in wrap op (,) allStakes stakeWithLock
+
+mkStakeRedeemer :: Operation -> StakeRedeemer
+mkStakeRedeemer op = wrap op const PermitVote RetractVotes
+
+mkStakeRef :: Integer -> TxOutRef
+mkStakeRef o = TxOutRef stakeTxRef $ 1 + o
+
+privilegeEscalate :: forall b. CombinableBuilder b => Operation -> b
+privilegeEscalate op =
+  let sst = assetClassValue stakeAssetClass 1
+
+      stakeValue = normalizeValue $ minAda <> sst
+
+      (stakeInputDatums, stakeOutputDatums) = mkStakeInputOutputDatums op
+
+      stakeBuilder =
+        mconcat $
+          zipWith3
+            ( \index stakeInput stakeOutput ->
+                mconcat @b
+                  [ input $
+                      mconcat
+                        [ script stakeValidatorHash
+                        , withDatum stakeInput
+                        , withValue stakeValue
+                        , withRef $ mkStakeRef index
+                        , withRedeemer $ mkStakeRedeemer op
+                        ]
+                  , output $
+                      mconcat
+                        [ script stakeValidatorHash
+                        , withDatum stakeOutput
+                        , withValue stakeValue
+                        ]
+                  ]
+            )
+            [1 ..]
+            stakeInputDatums
+            stakeOutputDatums
+
+      ---
+
+      pst = assetClassValue proposalAssetClass 1
+
+      proposalValue = normalizeValue $ minAda <> pst
+
+      (proposalInput, proposalOutput) = mkProposalInputOutputDatum op
+
+      proposalBuilder =
+        mconcat @b
+          [ input $
+              mconcat
+                [ script proposalValidatorHash
+                , withDatum proposalInput
+                , withRedeemer $ mkProposalRedeemer op
+                , withValue proposalValue
+                , withRef proposalRef
+                ]
+          , output $
+              mconcat
+                [ script proposalValidatorHash
+                , withDatum proposalOutput
+                , withValue proposalValue
+                ]
+          ]
+
+      ---
+
+      validTimeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).draftTime + 1)
+          ((def :: ProposalTimingConfig).votingTime - 1)
+
+      miscBuilder =
+        mconcat @b
+          [ signedWith attacker
+          , timeRange validTimeRange
+          ]
+   in mconcat
+        [ miscBuilder
+        , stakeBuilder
+        , proposalBuilder
+        ]
+
+mkTestTree :: String -> Operation -> Validity -> SpecificationTree
+mkTestTree name op val = group name [proposal, stake]
+  where
+    spend = mkSpending privilegeEscalate op
+
+    proposal =
+      testValidator
+        val.forProposalValidator
+        "proposal"
+        proposalValidator
+        (fst $ mkProposalInputOutputDatum op)
+        (mkProposalRedeemer op)
+        (spend proposalRef)
+
+    stakeInputdDatum = head $ fst $ mkStakeInputOutputDatums op
+
+    stake =
+      testValidator
+        val.forStakeValidator
+        "stake"
+        stakeValidator
+        stakeInputdDatum
+        (mkStakeRedeemer op)
+        (spend $ mkStakeRef 1)

agora-specs/Sample/Stake.hs

@@ -11,9 +11,6 @@ module Sample.Stake (
   signer,
 
   -- * Script contexts
-  stakeCreation,
-  stakeCreationWrongDatum,
-  stakeCreationUnsigned,
   stakeDepositWithdraw,
   DepositWithdrawExample (..),
 ) where
@@ -25,36 +22,24 @@ import Agora.Stake (
  )
 import Data.Tagged (Tagged)
 import Plutarch.Context (
-  MintingBuilder,
   SpendingBuilder,
-  buildMinting',
   buildSpending',
   input,
-  mint,
   output,
   script,
   signedWith,
   txId,
   withDatum,
-  withMinting,
   withRef,
   withSpendingOutRef,
   withValue,
  )
 import Plutarch.Extra.AssetClass (assetClassValue)
 import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
-import PlutusLedgerApi.V1.Value qualified as Value (
-  singleton,
- )
 import PlutusLedgerApi.V2 (
   Credential (PubKeyCredential),
-  Datum (Datum),
   ScriptContext (..),
-  ScriptPurpose (Minting),
-  ToData (toBuiltinData),
-  TxInfo (txInfoData, txInfoSignatories),
  )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Shared (
   governor,
   signer,
@@ -64,52 +49,6 @@ import Sample.Shared (
  )
 import Test.Util (sortValue)
 
--- | This script context should be a valid transaction.
-stakeCreation :: ScriptContext
-stakeCreation =
-  let st = assetClassValue stakeAssetClass 1 -- Stake ST
-      datum :: StakeDatum
-      datum = StakeDatum 424242424242 (PubKeyCredential signer) Nothing []
-
-      builder :: MintingBuilder
-      builder =
-        mconcat
-          [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-          , signedWith signer
-          , mint st
-          , output $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
-                , withDatum datum
-                ]
-          , withMinting stakeSymbol
-          ]
-   in buildMinting' builder
-
--- | This ScriptContext should fail because the datum has too much GT.
-stakeCreationWrongDatum :: ScriptContext
-stakeCreationWrongDatum =
-  let datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 (PubKeyCredential signer) Nothing []) -- Too much GT
-   in ScriptContext
-        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = AssocMap.fromList [("", 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

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]
+              }
+    }

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
+    }

agora-specs/Spec/Proposal.hs

@@ -10,6 +10,7 @@ module Spec.Proposal (specs) where
 import Sample.Proposal.Advance qualified as Advance
 import Sample.Proposal.Cosign qualified as Cosign
 import Sample.Proposal.Create qualified as Create
+import Sample.Proposal.PrivilegeEscalate qualified as PrivilegeEscalate
 import Sample.Proposal.Unlock qualified as Unlock
 import Sample.Proposal.Vote qualified as Vote
 
@@ -397,4 +398,15 @@ specs =
               illegalGroup = group "illegal" $ map mkIllegalGroup stakeCountCases
            in [legalGroup, illegalGroup]
       ]
+  , group
+      "privilege escalate"
+      [ PrivilegeEscalate.mkTestTree
+          "vote"
+          PrivilegeEscalate.Voting
+          (PrivilegeEscalate.Validity False False)
+      , PrivilegeEscalate.mkTestTree
+          "retract votes"
+          PrivilegeEscalate.RetractingVotes
+          (PrivilegeEscalate.Validity False False)
+      ]
   ]

agora-specs/Spec/Stake.hs

@@ -13,10 +13,8 @@ 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.Shared (stakeValidator)
 import Sample.Stake (
   DepositWithdrawExample (
     DepositWithdrawExample,
@@ -26,46 +24,117 @@ import Sample.Stake (
   signer,
  )
 import Sample.Stake qualified as Stake (
-  stakeCreation,
-  stakeCreationUnsigned,
-  stakeCreationWrongDatum,
   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,
   group,
-  policyFailsWith,
-  policySucceedsWith,
   validatorFailsWith,
   validatorSucceedsWith,
  )
-import Prelude (Num (negate), ($))
 
 -- | The SpecificationTree exported by this module.
 specs :: [SpecificationTree]
 specs =
   [ group
       "policy"
-      [ policySucceedsWith
+      [ group
-          "stakeCreation"
+          "create"
-          stakePolicy
+          [ group
-          ()
+              "valid"
-          Stake.stakeCreation
+              [ Create.mkTestCase
-      , policyFailsWith
+                  "stake owner: pub key"
-          "stakeCreationWrongDatum"
+                  Create.ownerIsPubKeyTotallyValid
-          stakePolicy
+                  True
-          ()
+              , Create.mkTestCase
-          Stake.stakeCreationWrongDatum
+                  "stake owner: script"
-      , policyFailsWith
+                  Create.ownerIsScriptTotallyValid
-          "stakeCreationUnsigned"
+                  True
-          stakePolicy
+              ]
-          ()
+          , group
-          Stake.stakeCreationUnsigned
+              "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
+              ]
+          ]
       ]
   , 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 True) 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 [])

agora.cabal

@@ -199,11 +199,14 @@ library agora-specs
     Sample.Proposal.Advance
     Sample.Proposal.Cosign
     Sample.Proposal.Create
+    Sample.Proposal.PrivilegeEscalate
     Sample.Proposal.Shared
     Sample.Proposal.Unlock
     Sample.Proposal.Vote
     Sample.Shared
     Sample.Stake
+    Sample.Stake.Create
+    Sample.Stake.Destroy
     Sample.Stake.SetDelegate
     Sample.Treasury
     Spec.AuthorityToken

agora/Agora/Stake/Scripts.hs

@@ -43,7 +43,6 @@ import Agora.Stake (
     PStakeRedeemerHandlerContext
   ),
   StakeRedeemerImpl (..),
-  pstakeLocked,
  )
 import Agora.Stake.Redeemers (
   pclearDelegate,
@@ -53,7 +52,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 +72,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 (
@@ -151,26 +150,16 @@ stakePolicy =
                 pto $
                   pfoldMap @_ @_ @(PSum PInteger)
                     # plam
-                      ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
+                      ( \((pfield @"resolved" #) -> txOut) ->
-                          txOutF <- pletFieldsC @'["value", "datum"] txOut
-
                           let isStakeUTxO =
-                                psymbolValueOf # ownSymbol # txOutF.value #== 1
+                                psymbolValueOf
-
+                                  # ownSymbol
-                          pmatchC isStakeUTxO
+                                  # (pfield @"value" # txOut)
-                            >>= \case
+                                  #== 1
-                              PTrue -> do
+                           in pif
-                                let datum =
+                                isStakeUTxO
-                                      pfromData $
+                                (pcon $ PSum 1)
-                                        pfromOutputDatum @(PAsData PStakeDatum)
+                                mempty
-                                          # txOutF.datum
-                                          # txInfoF.datums
-
-                                pguardC "Stake is unlocked" $
-                                  pnot # (pstakeLocked # datum)
-
-                                pure $ pcon $ PSum 1
-                              PFalse -> pure mempty
                       )
                     # pfromData txInfoF.inputs
 
@@ -207,24 +196,31 @@ stakePolicy =
                       # pfromData txInfoF.outputs
 
               outputF <-
-                pletFieldsC @'["value", "address", "datum"] scriptOutputWithStakeST
+                pletFieldsC @'["value", "datum"]
-              datumF <-
+                  scriptOutputWithStakeST
-                pletFieldsC @'["owner", "stakedAmount"] $
-                  pto $
-                    pfromData $
-                      pfromOutputDatum @(PAsData PStakeDatum) # outputF.datum # txInfoF.datums
 
-              let hasExpectedStake =
+              datumF <-
-                    ptraceIfFalse "Stake ouput has expected amount of stake token" $
+                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
-
+                  , ptraceIfFalse "Initial delegatee should set to nothing" $
-              pure $ hasExpectedStake #&& ownerSignsTransaction
+                      pisDNothing # datumF.delegatedTo
+                  , ptraceIfFalse "Initial locks should be empty" $
+                      pnull # pfromData datumF.lockedBy
+                  ]
 
           pure $ popaque (pconstant ())
 

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

bench.csv

@@ -4,7 +4,15 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries
 Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,300492604,786706,4250
 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,123980615,348263,11521
 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,145816056,387807,4684
-Agora/Stake/policy/stakeCreation,59498953,158188,3481
+Agora/Stake/policy/create/valid/stake owner: pub key,76591830,196946,3583
+Agora/Stake/policy/create/valid/stake owner: script,89731086,235525,3618
+Agora/Stake/validator/destroy/legal/One stake/stake validator,107112511,299069,7414
+Agora/Stake/validator/destroy/legal/One stake/stake policy,42685276,121860,3570
+Agora/Stake/validator/destroy/legal/Multiple stake/stake validator,693758152,1779821,10667
+Agora/Stake/validator/destroy/legal/Multiple stake/stake policy,418433413,1153422,6822
+Agora/Stake/validator/destroy/illegal/Destroy locked stakes/stake policy,418433413,1153422,6883
+Agora/Stake/validator/destroy/illegal/not authorized by owner/stake policy,418433413,1153422,6791
+Agora/Stake/validator/destroy/illegal/not authorized by owner/stake policy,418433413,1153422,6822
 Agora/Stake/validator/stakeDepositWithdraw deposit,147174364,403343,7529
 Agora/Stake/validator/stakeDepositWithdraw withdraw,147174364,403343,7521
 Agora/Stake/validator/set delegate/override existing delegate,179507112,476672,7660