Sulkta-OSS/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add some tests for Stake validator

Browse source
This commit is contained in:
Emily Martins 2022-03-23 21:35:05 +01:00
parent 3ada0095b3
commit 3578e7c47e
5 changed files with 194 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

63
agora-test/Spec/Sample/Stake.hs
View file

@ -10,11 +10,14 @@ module Spec.Sample.Stake (
policy,
policySymbol,
validatorHashTN,
signer,
-- * Script contexts
stakeCreation,
stakeCreationWrongDatum,
stakeCreationUnsigned,
stakeDepositWithdraw,
DepositWithdrawExample (..),
) where
--------------------------------------------------------------------------------
@ -36,11 +39,12 @@ import Plutus.V1.Ledger.Api (
ScriptContext (..),
ScriptPurpose (..),
ToData (toBuiltinData),
TxInInfo (TxInInfo),
TxInfo (..),
TxOut (txOutAddress, txOutDatumHash, txOutValue),
ValidatorHash (ValidatorHash),
)
import Plutus.V1.Ledger.Contexts (TxOut (TxOut))
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator)
import Plutus.V1.Ledger.Value (TokenName (TokenName))
@ -50,6 +54,7 @@ import Plutus.V1.Ledger.Value qualified as Value
import Agora.SafeMoney
import Agora.Stake
import Spec.Util (datumPair, toDatumHash)
--------------------------------------------------------------------------------
@ -120,3 +125,59 @@ stakeCreationUnsigned =
}
, scriptContextPurpose = Minting policySymbol
}
--------------------------------------------------------------------------------
data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Integer
, delta :: Integer
}
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
stakeDepositWithdraw config =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
stakeBefore :: StakeDatum
stakeBefore = StakeDatum config.startAmount signer
stakeAfter :: StakeDatum
stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
in ScriptContext
{ scriptContextTxInfo =
TxInfo
{ txInfoInputs =
[ TxInInfo
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutValue =
st
<> Value.singleton
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
"LQ"
stakeBefore.stakedAmount
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutValue =
st
<> Value.singleton
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
"LQ"
stakeAfter.stakedAmount
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]
, txInfoFee = Value.singleton "" "" 2
, txInfoMint = st
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = [signer]
, txInfoData = [datumPair stakeAfter]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
}
, scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
}

23
agora-test/Spec/Stake.hs
View file

@ -14,12 +14,13 @@ import Plutarch.Builtin (pforgetData)
--------------------------------------------------------------------------------
import Agora.Stake (stakePolicy)
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
--------------------------------------------------------------------------------
import Spec.Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
import Spec.Sample.Stake qualified as Stake
import Spec.Util (policyFailsWith, policySucceedsWith)
import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWith, validatorSucceedsWith)
--------------------------------------------------------------------------------
@ -42,5 +43,23 @@ tests =
(stakePolicy Stake.stake)
(pforgetData (pconstantData ()))
Stake.stakeCreationUnsigned
, validatorSucceedsWith
"stakeDepositWithdraw deposit"
(stakeValidator Stake.stake)
(pforgetData (pconstantData . toDatum $ StakeDatum 100_000 signer))
(pforgetData (pconstantData . toDatum $ DepositWithdraw 100_000))
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
, validatorSucceedsWith
"stakeDepositWithdraw withdraw"
(stakeValidator Stake.stake)
(pforgetData (pconstantData . toDatum $ StakeDatum 100_000 signer))
(pforgetData (pconstantData . toDatum $ DepositWithdraw (negate 100_000)))
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
, validatorFailsWith
"stakeDepositWithdraw negative GT"
(stakeValidator Stake.stake)
(pforgetData (pconstantData . toDatum $ StakeDatum 100_000 signer))
(pforgetData (pconstantData . toDatum $ DepositWithdraw (negate 1_000_000)))
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
]
]

56
agora-test/Spec/Util.hs
View file

@ -1,8 +1,17 @@
module Spec.Util (
-- * Testing utils
scriptSucceeds,
scriptFails,
policySucceedsWith,
policyFailsWith,
validatorSucceedsWith,
validatorFailsWith,
-- * Plutus land utils
datumHash,
toDatum,
toDatumHash,
datumPair,
) where
--------------------------------------------------------------------------------
@ -11,16 +20,24 @@ import Prelude
--------------------------------------------------------------------------------
import Codec.Serialise (serialise)
import Data.ByteString.Lazy qualified as LBS
--------------------------------------------------------------------------------
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (assertFailure, testCase)
--------------------------------------------------------------------------------
import Plutarch
import Plutarch.Api.V1 (PMintingPolicy)
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
import Plutarch.Crypto (pblake2b_256)
import Plutarch.Evaluate (evalScript)
import Plutarch.Prelude ()
import Plutus.V1.Ledger.Scripts (Script)
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
import PlutusTx.Builtins qualified as PlutusTx
import PlutusTx.IsData qualified as PlutusTx
--------------------------------------------------------------------------------
@ -32,6 +49,14 @@ policyFailsWith :: String -> ClosedTerm PMintingPolicy -> ClosedTerm PData -> _
policyFailsWith tag policy redeemer scriptContext =
scriptFails tag $ compile (policy # redeemer # pconstant scriptContext)
validatorSucceedsWith :: String -> ClosedTerm PValidator -> ClosedTerm PData -> ClosedTerm PData -> _ -> TestTree
validatorSucceedsWith tag policy datum redeemer scriptContext =
scriptSucceeds tag $ compile (policy # datum # redeemer # pconstant scriptContext)
validatorFailsWith :: String -> ClosedTerm PValidator -> ClosedTerm PData -> ClosedTerm PData -> _ -> TestTree
validatorFailsWith tag policy datum redeemer scriptContext =
scriptFails tag $ compile (policy # datum # redeemer # pconstant scriptContext)
scriptSucceeds :: String -> Script -> TestTree
scriptSucceeds name script = testCase name $ do
let (res, _budget, traces) = evalScript script
@ -51,3 +76,30 @@ scriptFails name script = testCase name $ do
Right v ->
assertFailure $
"Expected failure, but succeeded. " <> show v <> " Traces: " <> show traces
--------------------------------------------------------------------------------
{- | Create a pair from data for use in 'txInfoData'
Example:
@
myTxInfo { 'txInfoData' = ['datumPair' myDatum] }
@
-}
datumPair :: PlutusTx.ToData a => a -> (DatumHash, Datum)
datumPair = (,) <$> toDatumHash <*> toDatum
datumHash :: Datum -> DatumHash
datumHash (Datum data') = toDatumHash data'
toDatum :: PlutusTx.ToData a => a -> Datum
toDatum = Datum . PlutusTx.toBuiltinData
-- Shamelessly go through plutus.
toDatumHash :: PlutusTx.ToData a => a -> DatumHash
toDatumHash datum =
DatumHash $
PlutusTx.toBuiltin $
plift $
pblake2b_256
# pconstant (LBS.toStrict $ serialise $ PlutusTx.toData datum)

17
agora/Agora/SafeMoney.hs
View file

@ -13,6 +13,8 @@ module Agora.SafeMoney (
-- * Utility functions
paddDiscrete,
pgeqDiscrete,
pzeroDiscrete,
-- * Conversions
pdiscreteValue,
@ -56,7 +58,7 @@ type MoneyClass =
Nat
)
-- | A `PDiscrete` amount of currency tagged on the type level with the `MoneyClass` it belong sto
-- | A 'PDiscrete' amount of currency tagged on the type level with the 'MoneyClass' it belongs to
newtype PDiscrete (mc :: MoneyClass) (s :: S)
= PDiscrete (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger)
@ -65,7 +67,18 @@ newtype Discrete (mc :: MoneyClass)
= Discrete Integer
deriving stock (Show)
-- | Add two `PDiscrete` values of the same `MoneyClass`.
-- | Check if one 'PDiscrete' is greater than another.
pgeqDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc :--> PDiscrete mc :--> PBool)
pgeqDiscrete = phoistAcyclic $
plam $ \x y -> P.do
PDiscrete x' <- pmatch x
PDiscrete y' <- pmatch y
y' #<= x'
pzeroDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc)
pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
-- | Add two 'PDiscrete' values of the same 'MoneyClass'.
paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc)
paddDiscrete = phoistAcyclic $
-- In the future, this should use plutarch-numeric

52
agora/Agora/Stake.hs
View file

@ -9,8 +9,9 @@ Vote-lockable stake UTXOs holding GT.
-}
module Agora.Stake (
PStakeDatum (..),
PStakeAction (..),
PStakeRedeemer (..),
StakeDatum (..),
StakeRedeemer (..),
Stake (..),
stakePolicy,
stakeValidator,
@ -62,6 +63,8 @@ import Agora.SafeMoney (
PDiscrete,
paddDiscrete,
pdiscreteValue,
pgeqDiscrete,
pzeroDiscrete,
)
import Agora.Utils (
anyInput,
@ -84,7 +87,7 @@ import Agora.Utils (
data Stake (gt :: MoneyClass) = Stake
-- | Plutarch-level redeemer for Stake scripts.
data PStakeAction (gt :: MoneyClass) (s :: S)
data PStakeRedeemer (gt :: MoneyClass) (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete gt]))
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
@ -94,7 +97,23 @@ data PStakeAction (gt :: MoneyClass) (s :: S)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData)
via PIsDataReprInstances (PStakeAction gt)
via PIsDataReprInstances (PStakeRedeemer gt)
-- FIXME: 'StakeRedeemer' and 'StakeDatum' are stripped of their
-- typesafe `PDiscrete` equivalent due to issues with `makeIsDataIndexed`
-- when using the kind @gt :: MoneyClass@. This ought to be fixed with
-- a future patch in Plutarch upstream. For now, we will deal with lower
-- type safety off-chain.
-- | Haskell-level redeemer for Stake scripts.
data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token.
DepositWithdraw Integer
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
Destroy
deriving stock (Show, GHC.Generic)
PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
-- | Plutarch-level datum for Stake scripts.
newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum
@ -110,7 +129,8 @@ newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum
-- | Haskell-level datum for Stake scripts.
data StakeDatum = StakeDatum
{ stakedAmount :: Integer
{ -- FIXME: This needs to be gt
stakedAmount :: Integer
, owner :: PubKeyHash
}
deriving stock (Show, GHC.Generic)
@ -253,8 +273,8 @@ stakeValidator stake =
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
-- Coercion is safe in that if coercion fails we crash hard.
let stakeAction :: Term _ (PStakeAction gt)
stakeAction = pfromData $ punsafeCoerce redeemer
let stakeRedeemer :: Term _ (PStakeRedeemer gt)
stakeRedeemer = pfromData $ punsafeCoerce redeemer
stakeDatum' :: Term _ (PStakeDatum gt)
stakeDatum' = pfromData $ punsafeCoerce datum
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
@ -269,7 +289,7 @@ stakeValidator stake =
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo'
pmatch stakeAction $ \case
pmatch stakeRedeemer $ \case
PDestroy _ -> P.do
passert "ST at inputs must be 1" $
spentST #== 1
@ -297,8 +317,14 @@ stakeValidator stake =
delta <- plet $ pfield @"delta" # r
let isScriptAddress = pdata address #== ownAddress
let correctOutputDatum =
stakeDatum.owner #== newStakeDatum.owner
#&& (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount
foldr1
(#&&)
[ stakeDatum.owner #== newStakeDatum.owner
, (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount
, -- We can't magically conjure GT anyway (no input to spend!)
-- do we need to check this, really?
pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete
]
let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta)
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
@ -321,7 +347,13 @@ stakeValidator stake =
# value
# expectedValue
]
isScriptAddress #&& correctOutputDatum #&& valueCorrect
foldr1
(#&&)
[ ptraceIfFalse "isScriptAddress" isScriptAddress
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
, ptraceIfFalse "valueCorrect" valueCorrect
]
popaque (pconstant ())