tests for creating stakes

agora-specs/Sample/Stake/Create.hs

@@ -0,0 +1,260 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Sample.Stake.Create (
+  StakeDatumWrapper (..),
+  Parameters (..),
+  create,
+  mkTestCase,
+  ownerIsPubKeyTotallyValid,
+  ownerIsScriptTotallyValid,
+  createMoreThanOneStake,
+  spendStake,
+  unexpectedStakedAmount,
+  noStakeDatum,
+  malformedStakeDatum,
+  notAuthorizedByOwner,
+  setDelegatee,
+  alreadyHasLocks,
+) where
+
+import Agora.Governor (Governor (gtClassRef))
+import Agora.Proposal (ProposalId (ProposalId))
+import Agora.SafeMoney (GTTag)
+import Agora.Stake (ProposalLock (Created), StakeDatum (..))
+import Agora.Utils (validatorHashToTokenName)
+import Data.Semigroup (stimesMonoid)
+import Data.Tagged (Tagged)
+import Plutarch.Context (
+  input,
+  mint,
+  normalizeValue,
+  output,
+  pubKey,
+  script,
+  signedWith,
+  withDatum,
+  withValue,
+ )
+import Plutarch.Extra.AssetClass (assetClassValue)
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  Credential (
+    PubKeyCredential,
+    ScriptCredential
+  ),
+ )
+import Sample.Shared (
+  governor,
+  signer,
+  signer2,
+  stakePolicy,
+  stakeSymbol,
+  stakeValidatorHash,
+ )
+import Test.Specification (SpecificationTree, testPolicy)
+import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
+
+data StakeDatumWrapper
+  = forall (b :: Type) (p :: S -> Type).
+    (PUnsafeLiftDecl p, PLifted p ~ b, PIsData p) =>
+    StakeDatumWrapper b
+
+data Parameters = Parameters
+  { numSSTMinted :: Integer
+  , invalidSSTName :: Bool
+  , stakeAtInput :: Bool
+  , numGTsInValue :: Tagged GTTag Integer
+  , stakeDatum :: Maybe StakeDatumWrapper
+  , authorizedBy :: Maybe Credential
+  }
+
+create :: forall b. CombinableBuilder b => Parameters -> b
+create ps@Parameters {stakeDatum} =
+  let perStakeGTs =
+        assetClassValue
+          governor.gtClassRef
+          ps.numGTsInValue
+
+      gtValue =
+        stimesMonoid ps.numSSTMinted perStakeGTs
+
+      gtInputBuilder =
+        mconcat
+          [ input $
+              mconcat
+                [ pubKey signer
+                , withValue $ normalizeValue gtValue
+                ]
+          ]
+
+      ---
+
+      sstName =
+        if ps.invalidSSTName
+          then "114514"
+          else validatorHashToTokenName stakeValidatorHash
+
+      sst = Value.singleton stakeSymbol sstName 1
+
+      withStakeDatum =
+        maybe
+          mempty
+          (\(StakeDatumWrapper stakeDatum) -> withDatum stakeDatum)
+          stakeDatum
+
+      stakeBuilder =
+        mconcat
+          [ script stakeValidatorHash
+          , withValue $ normalizeValue $ sst <> perStakeGTs
+          , withStakeDatum
+          ]
+
+      stakeInputBuilder =
+        if ps.stakeAtInput
+          then input stakeBuilder
+          else mempty
+
+      stakeOutputBuilder =
+        stimesMonoid ps.numSSTMinted $
+          output stakeBuilder
+
+      ---
+
+      withAuthorization =
+        maybe
+          mempty
+          ( \case
+              PubKeyCredential pkh -> signedWith pkh
+              ScriptCredential val -> input $ script val
+          )
+          ps.authorizedBy
+
+      ---
+
+      mintSSTs = mint $ stimesMonoid ps.numSSTMinted sst
+   in mconcat
+        [ gtInputBuilder
+        , stakeInputBuilder
+        , stakeOutputBuilder
+        , withAuthorization
+        , mintSSTs
+        ]
+
+mkTestCase :: String -> Parameters -> Bool -> SpecificationTree
+mkTestCase name ps val = stake
+  where
+    mint = mkMinting create ps
+
+    stake =
+      testPolicy
+        val
+        name
+        stakePolicy
+        ()
+        (mint stakeSymbol)
+
+mkTotallyValid :: Integer -> Credential -> Parameters
+mkTotallyValid gts owner =
+  Parameters
+    { numSSTMinted = 1
+    , invalidSSTName = False
+    , numGTsInValue = fromInteger gts
+    , stakeAtInput = False
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = fromInteger gts
+              , owner = owner
+              , delegatedTo = Nothing
+              , lockedBy = []
+              }
+    , authorizedBy = Just owner
+    }
+
+ownerIsPubKeyTotallyValid :: Parameters
+ownerIsPubKeyTotallyValid = mkTotallyValid 114514 (PubKeyCredential signer)
+
+ownerIsScriptTotallyValid :: Parameters
+ownerIsScriptTotallyValid =
+  mkTotallyValid
+    114514
+    ( ScriptCredential $
+        head validatorHashes
+    )
+
+createMoreThanOneStake :: Parameters
+createMoreThanOneStake =
+  ownerIsPubKeyTotallyValid
+    { numSSTMinted = 5
+    }
+
+spendStake :: Parameters
+spendStake =
+  ownerIsPubKeyTotallyValid
+    { stakeAtInput = True
+    }
+
+unexpectedStakedAmount :: Parameters
+unexpectedStakedAmount =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 1919810
+              , owner = PubKeyCredential signer
+              , delegatedTo = Nothing
+              , lockedBy = []
+              }
+    }
+
+noStakeDatum :: Parameters
+noStakeDatum =
+  ownerIsPubKeyTotallyValid
+    { stakeDatum = Nothing
+    }
+
+malformedStakeDatum :: Parameters
+malformedStakeDatum =
+  ownerIsPubKeyTotallyValid
+    { stakeDatum = Just $ StakeDatumWrapper (1 :: Integer)
+    }
+
+notAuthorizedByOwner :: Parameters
+notAuthorizedByOwner =
+  ownerIsPubKeyTotallyValid
+    { authorizedBy = Nothing
+    }
+
+setDelegatee :: Parameters
+setDelegatee =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 114514
+              , owner = PubKeyCredential signer
+              , delegatedTo = Just $ PubKeyCredential signer2
+              , lockedBy = []
+              }
+    }
+
+alreadyHasLocks :: Parameters
+alreadyHasLocks =
+  ownerIsPubKeyTotallyValid
+    { numGTsInValue = 114514
+    , stakeDatum =
+        Just $
+          StakeDatumWrapper $
+            StakeDatum
+              { stakedAmount = 114514
+              , owner = PubKeyCredential signer
+              , delegatedTo = Nothing
+              , lockedBy = [Created $ ProposalId 0]
+              }
+    }

agora-specs/Spec/Stake.hs

@@ -13,8 +13,6 @@ import Agora.Stake (
   StakeDatum (StakeDatum),
   StakeRedeemer (DepositWithdraw),
  )
-import Data.Bool (Bool (..))
-import Data.Maybe (Maybe (..))
 import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
 import Sample.Shared (stakePolicy, stakeValidator)
 import Sample.Stake (
@@ -31,6 +29,7 @@ import Sample.Stake qualified as Stake (
   stakeCreationWrongDatum,
   stakeDepositWithdraw,
  )
+import Sample.Stake.Create qualified as Create
 import Sample.Stake.SetDelegate qualified as SetDelegate
 import Test.Specification (
   SpecificationTree,
@@ -40,14 +39,62 @@ import Test.Specification (
   validatorFailsWith,
   validatorSucceedsWith,
  )
-import Prelude (Num (negate), ($))
 
 -- | The SpecificationTree exported by this module.
 specs :: [SpecificationTree]
 specs =
   [ group
       "policy"
-      [ policySucceedsWith
+      [ group
+          "create"
+          [ group
+              "valid"
+              [ Create.mkTestCase
+                  "stake owner: pub key"
+                  Create.ownerIsPubKeyTotallyValid
+                  True
+              , Create.mkTestCase
+                  "stake owner: script"
+                  Create.ownerIsScriptTotallyValid
+                  True
+              ]
+          , group
+              "invalid"
+              [ Create.mkTestCase
+                  "mint more than one sst in one tx"
+                  Create.createMoreThanOneStake
+                  False
+              , Create.mkTestCase
+                  "spend stake while minting SST"
+                  Create.spendStake
+                  False
+              , Create.mkTestCase
+                  "wrong staked amount"
+                  Create.unexpectedStakedAmount
+                  False
+              , Create.mkTestCase
+                  "no stake datum"
+                  Create.noStakeDatum
+                  False
+              , Create.mkTestCase
+                  "bad stake datum"
+                  Create.malformedStakeDatum
+                  False
+              , Create.mkTestCase
+                  "not authorized by owner"
+                  Create.notAuthorizedByOwner
+                  False
+              , Create.mkTestCase
+                  "delegatee not empty"
+                  Create.setDelegatee
+                  False
+              , Create.mkTestCase
+                  "have locks"
+                  Create.alreadyHasLocks
+                  False
+              ]
+          ]
+      , policySucceedsWith
           "stakeCreation"
           stakePolicy
           ()

agora.cabal

@@ -204,6 +204,7 @@ library agora-specs
     Sample.Proposal.Vote
     Sample.Shared
     Sample.Stake
+    Sample.Stake.Create
     Sample.Stake.SetDelegate
     Sample.Treasury
     Spec.AuthorityToken

agora/Agora/Stake/Scripts.hs

@@ -53,7 +53,7 @@ import Agora.Stake.Redeemers (
   ppermitVote,
   pretractVote,
  )
-import Agora.Utils (passert, pmapMaybe)
+import Agora.Utils (passert, pisDNothing, pmapMaybe)
 import Plutarch.Api.V1 (
   PCredential (PPubKeyCredential, PScriptCredential),
   PCurrencySymbol,
@@ -73,7 +73,7 @@ import Plutarch.Extra.AssetClass (
   PAssetClassData,
   ptoScottEncoding,
  )
-import Plutarch.Extra.Field (pletAll)
+import Plutarch.Extra.Field (pletAll, pletAllC)
 import Plutarch.Extra.Functor (PFunctor (pfmap))
 import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
 import Plutarch.Extra.Maybe (
@@ -207,24 +207,31 @@ stakePolicy =
                       # pfromData txInfoF.outputs
 
               outputF <-
-                pletFieldsC @'["value", "address", "datum"] scriptOutputWithStakeST
+                pletFieldsC @'["value", "datum"]
-              datumF <-
+                  scriptOutputWithStakeST
-                pletFieldsC @'["owner", "stakedAmount"] $
-                  pto $
-                    pfromData $
-                      pfromOutputDatum @(PAsData PStakeDatum) # outputF.datum # txInfoF.datums
 
-              let hasExpectedStake =
+              datumF <-
-                    ptraceIfFalse "Stake ouput has expected amount of stake token" $
+                pletAllC $
+                  pfromData $
+                    pfromOutputDatum @(PAsData PStakeDatum)
+                      # outputF.datum
+                      # txInfoF.datums
+
+              pure $
+                foldl1
+                  (#&&)
+                  [ ptraceIfFalse "Stake ouput has expected amount of stake token" $
                       passetClassValueOf # (ptoScottEncoding # gstClass) # outputF.value
                         #== pto (pfromData datumF.stakedAmount)
-              let ownerSignsTransaction =
+                  , ptraceIfFalse "Stake Owner should sign the transaction" $
-                    ptraceIfFalse "Stake Owner should sign the transaction" $
                       pauthorizedBy
                         # authorizationContext txInfoF
                         # datumF.owner
-
+                  , ptraceIfFalse "Initial delegatee should set to nothing" $
-              pure $ hasExpectedStake #&& ownerSignsTransaction
+                      pisDNothing # datumF.delegatedTo
+                  , ptraceIfFalse "Initial locks should be empty" $
+                      pnull # pfromData datumF.lockedBy
+                  ]
 
           pure $ popaque (pconstant ())
 

agora/Agora/Utils.hs

@@ -31,11 +31,13 @@ module Agora.Utils (
   pinsertUniqueBy,
   ptryFromRedeemer,
   passert,
+  pisNothing,
+  pisDNothing,
 ) where
 
 import Plutarch.Api.V1 (KeyGuarantees (Unsorted), PPOSIXTime, PRedeemer, PTokenName, PValidatorHash)
 import Plutarch.Api.V1.AssocMap (PMap, plookup)
-import Plutarch.Api.V2 (PScriptHash, PScriptPurpose)
+import Plutarch.Api.V2 (PMaybeData (PDNothing), PScriptHash, PScriptPurpose)
 import Plutarch.Extra.Applicative (PApplicative (ppure))
 import Plutarch.Extra.Category (PCategory (pidentity))
 import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
@@ -385,3 +387,23 @@ passert ::
   Term s a ->
   Term s a
 passert msg cond x = pif cond x $ ptraceError msg
+
+-- | @since 1.0.0
+pisNothing ::
+  forall (a :: PType) (s :: S).
+  Term s (PMaybe a :--> PBool)
+pisNothing = phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PNothing -> pconstant True
+      _ -> pconstant False
+
+-- | @since 1.0.0
+pisDNothing ::
+  forall (a :: PType) (s :: S).
+  Term s (PMaybeData a :--> PBool)
+pisDNothing = phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PDNothing _ -> pconstant True
+      _ -> pconstant False