add some tests for Stake validator
This commit is contained in:
Emily Martins
parent
4acc857bbd
commit
78d104c213
5 changed files with 194 additions and 17 deletions
|
|
@ -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)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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})
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue