WIP simple sample test for Stake policy

agora-test/Spec.hs

@@ -9,14 +9,21 @@ import Test.Tasty (defaultMain, testGroup)
 --------------------------------------------------------------------------------
 
 import Spec.Int
+import Spec.Stake qualified as Stake
 
 main :: IO ()
 main =
   defaultMain $
     testGroup
-      "apropos-tx"
+      "test suite"
       [ testGroup
-          "Int"
-          [ intPlutarchTests
+          "sample-tests"
+          Stake.tests
+      , testGroup
+          "apropos-tx"
+          [ testGroup
+              "Int"
+              [ intPlutarchTests
+              ]
           ]
       ]

agora-test/Spec/Sample/Stake.hs

@@ -0,0 +1,97 @@
+{- |
+Module     : Spec.Sample.Stake
+Maintainer : emi@haskell.fyi
+Description: Sample based testing for Stake utxos
+
+This module tests primarily the happy path for Stake creation
+-}
+module Spec.Sample.Stake (
+  stake,
+  policy,
+  policySymbol,
+  stakeCreation,
+  validatorHashTN,
+) where
+
+--------------------------------------------------------------------------------
+
+import Plutarch.Api.V1 (
+  mintingPolicySymbol,
+  mkMintingPolicy,
+  mkValidator,
+  validatorHash,
+ )
+import Plutus.V1.Ledger.Ada (adaValueOf)
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  CurrencySymbol,
+  Datum (Datum),
+  DatumHash (DatumHash),
+  MintingPolicy (..),
+  PubKeyHash,
+  ScriptContext (..),
+  ScriptPurpose (..),
+  ToData (toBuiltinData),
+  TxInfo (..),
+  TxOut (txOutAddress, txOutDatumHash, txOutValue),
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Contexts (TxOut (TxOut))
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (Validator)
+import Plutus.V1.Ledger.Value (TokenName (TokenName))
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+import Agora.SafeMoney
+import Agora.Stake
+
+--------------------------------------------------------------------------------
+
+stake :: Stake LQ
+stake = Stake
+
+policy :: MintingPolicy
+policy = mkMintingPolicy (stakePolicy stake)
+
+policySymbol :: CurrencySymbol
+policySymbol = mintingPolicySymbol policy
+
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+validator :: Validator
+validator = mkValidator (stakeValidator stake)
+
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+
+stakeCreation :: ScriptContext
+stakeCreation =
+  let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
+      datum :: Datum
+      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs = []
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
+                      , txOutDatumHash = Just (DatumHash "")
+                      }
+                  ]
+              , txInfoFee = adaValueOf 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData = [("", datum)]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Minting policySymbol
+        }

agora-test/Spec/Stake.hs

@@ -0,0 +1,39 @@
+module Spec.Stake (tests) where
+
+--------------------------------------------------------------------------------
+
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertFailure, testCase)
+
+--------------------------------------------------------------------------------
+
+import Plutarch (compile)
+import Plutarch.Evaluate (evaluateScript)
+import Plutus.V1.Ledger.Scripts (Script)
+
+--------------------------------------------------------------------------------
+
+import Agora.Stake (stakePolicy)
+
+--------------------------------------------------------------------------------
+
+import Plutarch.Builtin (pforgetData)
+import Spec.Sample.Stake qualified as Stake
+
+--------------------------------------------------------------------------------
+tests :: [TestTree]
+tests =
+  [ testGroup "policy" $
+      [ scriptTest "minting" (compile $ stakePolicy Stake.stake # pforgetData (pconstantData ()) # pconstant Stake.stakeCreation)
+      ]
+  ]
+
+scriptTest :: String -> Script -> TestTree
+scriptTest name script = testCase name $ do
+  case evaluateScript script of
+    Left e -> assertFailure (show e)
+    Right _v -> pure ()