regression tests for unauthorized GAT minting exploit

agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs

@@ -0,0 +1,66 @@
+module Sample.AuthorityToken.UnauthorizedMintingExploit (
+  Parameters (..),
+  exploit,
+  mkTestCase,
+) where
+
+import Agora.Utils (validatorHashToTokenName)
+import Control.Exception (assert)
+import Plutarch.Context (input, mint, normalizeValue, output, script, withValue)
+import PlutusLedgerApi.V1.Value qualified as Value
+import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda)
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
+
+data Parameters = Parameters
+  { burntGAT :: Int
+  , mintedGAT :: Int
+  }
+
+exploit ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+exploit (Parameters burntGAT mintedGAT) =
+  assert (burntGAT > mintedGAT && mintedGAT > 0) $
+    effectInputBuilder <> maliciousGATOutputBuilder
+  where
+    (effectScriptHashes, rest) = splitAt burntGAT validatorHashes
+    maliciousScripts = take mintedGAT rest
+
+    gatValue hash =
+      Value.singleton
+        authorityTokenSymbol
+        (validatorHashToTokenName hash)
+
+    mkGATUTxO hash =
+      mconcat
+        [ script hash
+        , withValue $ normalizeValue $ minAda <> gatValue hash 1
+        ]
+
+    effectInputBuilder =
+      foldMap
+        ( \effectHash ->
+            mconcat
+              [ mint $ gatValue effectHash $ negate 1
+              , input $ mkGATUTxO effectHash
+              ]
+        )
+        effectScriptHashes
+
+    maliciousGATOutputBuilder =
+      foldMap
+        ( \scriptHash ->
+            mconcat
+              [ mint $ gatValue scriptHash 1
+              , output $ mkGATUTxO scriptHash
+              ]
+        )
+        maliciousScripts
+
+mkTestCase :: String -> Parameters -> SpecificationTree
+mkTestCase name ps =
+  testPolicy False name authorityTokenPolicy () $
+    mkMinting exploit ps authorityTokenSymbol