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

agora-specs/Spec/AuthorityToken.hs

@@ -10,7 +10,6 @@ Tests for Authority token functions
 module Spec.AuthorityToken (specs) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Plutarch (ClosedTerm, POpaque, perror, popaque)
 import Plutarch.Extra.Compile (mustCompile)
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1 (
@@ -29,21 +28,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
   singleton,
  )
 import PlutusTx.AssocMap qualified as AssocMap (empty)
+import Sample.AuthorityToken.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
 import Test.Specification (
   SpecificationTree,
   group,
   scriptFails,
   scriptSucceeds,
  )
-import Prelude (
-  Maybe (Nothing),
-  PBool,
-  Semigroup ((<>)),
-  fmap,
-  pconstant,
-  pif,
-  ($),
- )
 
 currencySymbol :: CurrencySymbol
 currencySymbol = "deadbeef"
@@ -150,4 +141,15 @@ specs =
               ]
           )
       ]
+  , group "unauthorized minting exploit"
+      $ map
+        ( UnauthorizedMintingExploit.mkTestCase "(negative test)"
+            . uncurry UnauthorizedMintingExploit.Parameters
+        )
+      $ let l = [1 .. 10]
+         in [ (burnt, minted)
+            | burnt <- l
+            , minted <- l
+            , minted < burnt
+            ]
   ]

agora.cabal

@@ -192,6 +192,7 @@ library agora-specs
   exposed-modules:
     Property.Generator
     Property.Governor
+    Sample.AuthorityToken.UnauthorizedMintingExploit
     Sample.Effect.GovernorMutation
     Sample.Effect.TreasuryWithdrawal
     Sample.Governor.Initialize