tests for destroying stakes

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/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 [])

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