diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 96a54ad..a2fa049 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -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) + } diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs index dd51749..c58598f 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -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}) ] ] diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 3db7f53..dafd5e2 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -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) diff --git a/agora/Agora/SafeMoney.hs b/agora/Agora/SafeMoney.hs index d40d99d..1eeb2c7 100644 --- a/agora/Agora/SafeMoney.hs +++ b/agora/Agora/SafeMoney.hs @@ -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 diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 610d49a..39f1eb1 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -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 ())