From fd7ef68b042c2d63603e85aa47a1e3195073ce83 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 16 Mar 2022 13:55:00 +0100
Subject: [PATCH] add intentionally failing examples

---
 agora-test/Spec/Sample/Stake.hs | 28 +++++++++++++++++++++++-
 agora-test/Spec/Stake.hs        | 19 ++++++++++++++---
 agora-test/Spec/Util.hs         | 38 ++++++++++++++++++++++++++++-----
 flake.nix                       |  1 +
 4 files changed, 77 insertions(+), 9 deletions(-)

diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs
index 55897c8..96a54ad 100644
--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@@ -9,8 +9,12 @@ module Spec.Sample.Stake (
   stake,
   policy,
   policySymbol,
-  stakeCreation,
   validatorHashTN,
+
+  -- * Script contexts
+  stakeCreation,
+  stakeCreationWrongDatum,
+  stakeCreationUnsigned,
 ) where
 
 --------------------------------------------------------------------------------
@@ -67,6 +71,7 @@ validator = mkValidator (stakeValidator stake)
 validatorHashTN :: TokenName
 validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 
+-- | This script context should be a valid transaction
 stakeCreation :: ScriptContext
 stakeCreation =
   let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
@@ -94,3 +99,24 @@ stakeCreation =
               }
         , scriptContextPurpose = Minting policySymbol
         }
+
+-- | This ScriptContext should fail because the datum has too much GT
+stakeCreationWrongDatum :: ScriptContext
+stakeCreationWrongDatum =
+  let datum :: Datum
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
+   in ScriptContext
+        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
+        , scriptContextPurpose = Minting policySymbol
+        }
+
+-- | This ScriptContext should fail because the datum has too much GT
+stakeCreationUnsigned :: ScriptContext
+stakeCreationUnsigned =
+  ScriptContext
+    { scriptContextTxInfo =
+        stakeCreation.scriptContextTxInfo
+          { txInfoSignatories = []
+          }
+    , scriptContextPurpose = Minting policySymbol
+    }
diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs
index c3ba408..dd51749 100644
--- a/agora-test/Spec/Stake.hs
+++ b/agora-test/Spec/Stake.hs
@@ -10,7 +10,6 @@ import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Plutarch (compile)
 import Plutarch.Builtin (pforgetData)
 
 --------------------------------------------------------------------------------
@@ -20,7 +19,7 @@ import Agora.Stake (stakePolicy)
 --------------------------------------------------------------------------------
 
 import Spec.Sample.Stake qualified as Stake
-import Spec.Util (scriptTest)
+import Spec.Util (policyFailsWith, policySucceedsWith)
 
 --------------------------------------------------------------------------------
 
@@ -28,6 +27,20 @@ tests :: [TestTree]
 tests =
   [ testGroup
       "policy"
-      [ scriptTest "minting" (compile $ stakePolicy Stake.stake # pforgetData (pconstantData ()) # pconstant Stake.stakeCreation)
+      [ policySucceedsWith
+          "stakeCreation"
+          (stakePolicy Stake.stake)
+          (pforgetData (pconstantData ()))
+          Stake.stakeCreation
+      , policyFailsWith
+          "stakeCreationWrongDatum"
+          (stakePolicy Stake.stake)
+          (pforgetData (pconstantData ()))
+          Stake.stakeCreationWrongDatum
+      , policyFailsWith
+          "stakeCreationUnsigned"
+          (stakePolicy Stake.stake)
+          (pforgetData (pconstantData ()))
+          Stake.stakeCreationUnsigned
       ]
   ]
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 9171641..3db7f53 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -1,4 +1,9 @@
-module Spec.Util (scriptTest) where
+module Spec.Util (
+  scriptSucceeds,
+  scriptFails,
+  policySucceedsWith,
+  policyFailsWith,
+) where
 
 --------------------------------------------------------------------------------
 
@@ -11,15 +16,38 @@ import Test.Tasty.HUnit (assertFailure, testCase)
 
 --------------------------------------------------------------------------------
 
+import Plutarch
+import Plutarch.Api.V1 (PMintingPolicy)
 import Plutarch.Evaluate (evalScript)
+import Plutarch.Prelude ()
 import Plutus.V1.Ledger.Scripts (Script)
 
 --------------------------------------------------------------------------------
 
-scriptTest :: String -> Script -> TestTree
-scriptTest name script = testCase name $ do
+policySucceedsWith :: String -> ClosedTerm PMintingPolicy -> ClosedTerm PData -> _ -> TestTree
+policySucceedsWith tag policy redeemer scriptContext =
+  scriptSucceeds tag $ compile (policy # redeemer # pconstant scriptContext)
+
+policyFailsWith :: String -> ClosedTerm PMintingPolicy -> ClosedTerm PData -> _ -> TestTree
+policyFailsWith tag policy redeemer scriptContext =
+  scriptFails tag $ compile (policy # redeemer # pconstant scriptContext)
+
+scriptSucceeds :: String -> Script -> TestTree
+scriptSucceeds name script = testCase name $ do
   let (res, _budget, traces) = evalScript script
   case res of
     Left e -> do
-      assertFailure (show e <> " Traces: " <> show traces)
-    Right _v -> pure ()
+      assertFailure $
+        show e <> " Traces: " <> show traces
+    Right _v ->
+      pure ()
+
+scriptFails :: String -> Script -> TestTree
+scriptFails name script = testCase name $ do
+  let (res, _budget, traces) = evalScript script
+  case res of
+    Left _e ->
+      pure ()
+    Right v ->
+      assertFailure $
+        "Expected failure, but succeeded. " <> show v <> " Traces: " <> show traces
diff --git a/flake.nix b/flake.nix
index 5086051..fdf0dd8 100644
--- a/flake.nix
+++ b/flake.nix
@@ -32,6 +32,7 @@
           overlays = [ haskell-nix.overlay ];
           inherit (haskell-nix) config;
         };
+
       nixpkgsFor' = system:
         import nixpkgs {
           inherit system;