regression tests for SST exploit

agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs

@@ -0,0 +1,74 @@
+module Sample.Stake.UnauthorizedMintingExploit (
+  Parameters (..),
+  exploit,
+  mkTestCase,
+) where
+
+import Agora.Utils (validatorHashToTokenName)
+import Plutarch.Context (
+  input,
+  mint,
+  normalizeValue,
+  output,
+  script,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import PlutusLedgerApi.V1.Value qualified as Value
+import Sample.Shared (
+  minAda,
+  stakeAssetClass,
+  stakePolicy,
+  stakeSymbol,
+  stakeValidatorHash,
+ )
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (
+  CombinableBuilder,
+  mkMinting,
+  validatorHashes,
+ )
+
+newtype Parameters = Parameters
+  { inputSST :: Int
+  }
+
+exploit ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+exploit (Parameters inputSST) =
+  mconcat
+    [ input $
+        mconcat
+          [ script attacker
+          , withValue $
+              normalizeValue $
+                minAda <> fakeSSTValue inputSST
+          ]
+    , mint $ fakeSSTValue $ negate inputSST
+    , mint sst
+    , output $
+        mconcat
+          [ script stakeValidatorHash
+          , withValue $
+              normalizeValue $
+                minAda <> sst
+          ]
+    ]
+  where
+    attacker = head validatorHashes
+
+    fakeSSTValue =
+      Value.singleton
+        stakeSymbol
+        (validatorHashToTokenName attacker)
+        . fromIntegral
+
+    sst = assetClassValue stakeAssetClass 1
+
+mkTestCase :: String -> Parameters -> SpecificationTree
+mkTestCase name ps =
+  testPolicy False name stakePolicy () $
+    mkMinting exploit ps stakeSymbol