diff --git a/CHANGELOG.md b/CHANGELOG.md index d21a584..8e03fb7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0). ### Modified +- Fix a bug where `lockedBy` and `delegatedTo` fields of stake datums aren't checked + during the creation of stakes. + + Included by [#199](https://github.com/Liqwid-Labs/agora/pull/199) + - Fix several vulnerabilities and bugs found in staking components. Including: diff --git a/agora-specs/Sample/Proposal/PrivilegeEscalate.hs b/agora-specs/Sample/Proposal/PrivilegeEscalate.hs new file mode 100644 index 0000000..24f4e30 --- /dev/null +++ b/agora-specs/Sample/Proposal/PrivilegeEscalate.hs @@ -0,0 +1,242 @@ +module Sample.Proposal.PrivilegeEscalate ( + Operation (..), + privilegeEscalate, + Validity (..), + mkTestTree, +) where + +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (ProposalId), + ProposalRedeemer (Unlock, Vote), + ProposalStatus (VotingReady), + ProposalVotes (ProposalVotes), + ResultTag (ResultTag), + emptyVotesFor, + ) +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig (draftTime, votingTime), + ) +import Agora.SafeMoney (GTTag) +import Agora.Stake ( + ProposalLock ( + Voted + ), + StakeDatum (..), + StakeRedeemer (PermitVote, RetractVotes), + ) +import Data.Default (Default (def)) +import Data.Map.Strict qualified as StrictMap +import Data.Tagged (Tagged, untag) +import Plutarch.Context ( + input, + normalizeValue, + output, + script, + signedWith, + timeRange, + withDatum, + withRedeemer, + withRef, + withValue, + ) +import Plutarch.Extra.AssetClass (assetClassValue) +import PlutusLedgerApi.V1 (Credential (PubKeyCredential)) +import PlutusLedgerApi.V2 (PubKeyHash, TxOutRef (TxOutRef)) +import Sample.Proposal.Shared (proposalTxRef, stakeTxRef) +import Sample.Shared ( + minAda, + proposalAssetClass, + proposalValidator, + proposalValidatorHash, + stakeAssetClass, + stakeValidator, + stakeValidatorHash, + ) +import Test.Specification (SpecificationTree, group, testValidator) +import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes) + +data Operation = Voting | RetractingVotes + +data Validity = Validity + { forStakeValidator :: Bool + , forProposalValidator :: Bool + } + +wrap :: forall x y. Operation -> (x -> x -> y) -> x -> x -> y +wrap Voting = id +wrap RetractingVotes = flip + +defStakeAmount :: Tagged GTTag Integer +defStakeAmount = 100000 + +defResultTag :: ResultTag +defResultTag = ResultTag 0 + +defProposalId :: ProposalId +defProposalId = ProposalId 0 + +mkProposalInputOutputDatum :: Operation -> (ProposalDatum, ProposalDatum) +mkProposalInputOutputDatum op = + let effects = StrictMap.singleton defResultTag StrictMap.empty + + proposal = + ProposalDatum + { proposalId = defProposalId + , effects = effects + , status = VotingReady + , cosigners = [] -- doesn't matter + , thresholds = def + , votes = emptyVotesFor effects + , timingConfig = def + , startingTime = ProposalStartingTime 0 + } + + proposalWithVotes = + proposal + { votes = + ProposalVotes $ + StrictMap.singleton defResultTag (untag defStakeAmount) + } + in wrap op (,) proposal proposalWithVotes + +mkProposalRedeemer :: Operation -> ProposalRedeemer +mkProposalRedeemer op = wrap op const (Vote defResultTag) Unlock + +proposalRef :: TxOutRef +proposalRef = TxOutRef proposalTxRef 1 + +attacker :: PubKeyHash +attacker = head pubKeyHashes + +mkStakeInputOutputDatums :: Operation -> ([StakeDatum], [StakeDatum]) +mkStakeInputOutputDatums op = + let delegatee = pubKeyHashes !! 1 + + firstStake = + StakeDatum + { stakedAmount = defStakeAmount + , owner = PubKeyCredential attacker + , delegatedTo = Just $ PubKeyCredential delegatee + , lockedBy = [] + } + + otherStakes = + (\pkh -> firstStake {owner = PubKeyCredential pkh}) + <$> drop 2 pubKeyHashes + + allStakes = take 10 $ firstStake : otherStakes + + stakeWithLock = + (\stake -> stake {lockedBy = [Voted defProposalId defResultTag]}) + <$> allStakes + in wrap op (,) allStakes stakeWithLock + +mkStakeRedeemer :: Operation -> StakeRedeemer +mkStakeRedeemer op = wrap op const PermitVote RetractVotes + +mkStakeRef :: Integer -> TxOutRef +mkStakeRef o = TxOutRef stakeTxRef $ 1 + o + +privilegeEscalate :: forall b. CombinableBuilder b => Operation -> b +privilegeEscalate op = + let sst = assetClassValue stakeAssetClass 1 + + stakeValue = normalizeValue $ minAda <> sst + + (stakeInputDatums, stakeOutputDatums) = mkStakeInputOutputDatums op + + stakeBuilder = + mconcat $ + zipWith3 + ( \index stakeInput stakeOutput -> + mconcat @b + [ input $ + mconcat + [ script stakeValidatorHash + , withDatum stakeInput + , withValue stakeValue + , withRef $ mkStakeRef index + , withRedeemer $ mkStakeRedeemer op + ] + , output $ + mconcat + [ script stakeValidatorHash + , withDatum stakeOutput + , withValue stakeValue + ] + ] + ) + [1 ..] + stakeInputDatums + stakeOutputDatums + + --- + + pst = assetClassValue proposalAssetClass 1 + + proposalValue = normalizeValue $ minAda <> pst + + (proposalInput, proposalOutput) = mkProposalInputOutputDatum op + + proposalBuilder = + mconcat @b + [ input $ + mconcat + [ script proposalValidatorHash + , withDatum proposalInput + , withRedeemer $ mkProposalRedeemer op + , withValue proposalValue + , withRef proposalRef + ] + , output $ + mconcat + [ script proposalValidatorHash + , withDatum proposalOutput + , withValue proposalValue + ] + ] + + --- + + validTimeRange = + closedBoundedInterval + ((def :: ProposalTimingConfig).draftTime + 1) + ((def :: ProposalTimingConfig).votingTime - 1) + + miscBuilder = + mconcat @b + [ signedWith attacker + , timeRange validTimeRange + ] + in mconcat + [ miscBuilder + , stakeBuilder + , proposalBuilder + ] + +mkTestTree :: String -> Operation -> Validity -> SpecificationTree +mkTestTree name op val = group name [proposal, stake] + where + spend = mkSpending privilegeEscalate op + + proposal = + testValidator + val.forProposalValidator + "proposal" + proposalValidator + (fst $ mkProposalInputOutputDatum op) + (mkProposalRedeemer op) + (spend proposalRef) + + stakeInputdDatum = head $ fst $ mkStakeInputOutputDatums op + + stake = + testValidator + val.forStakeValidator + "stake" + stakeValidator + stakeInputdDatum + (mkStakeRedeemer op) + (spend $ mkStakeRef 1) diff --git a/agora-specs/Sample/Stake.hs b/agora-specs/Sample/Stake.hs index e97fc53..9a2b982 100644 --- a/agora-specs/Sample/Stake.hs +++ b/agora-specs/Sample/Stake.hs @@ -11,9 +11,6 @@ module Sample.Stake ( signer, -- * Script contexts - stakeCreation, - stakeCreationWrongDatum, - stakeCreationUnsigned, stakeDepositWithdraw, DepositWithdrawExample (..), ) where @@ -25,36 +22,24 @@ import Agora.Stake ( ) import Data.Tagged (Tagged) import Plutarch.Context ( - MintingBuilder, SpendingBuilder, - buildMinting', buildSpending', input, - mint, output, script, signedWith, txId, withDatum, - withMinting, withRef, withSpendingOutRef, withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) import PlutusLedgerApi.V1.Contexts (TxOutRef (..)) -import PlutusLedgerApi.V1.Value qualified as Value ( - singleton, - ) import PlutusLedgerApi.V2 ( Credential (PubKeyCredential), - Datum (Datum), ScriptContext (..), - ScriptPurpose (Minting), - ToData (toBuiltinData), - TxInfo (txInfoData, txInfoSignatories), ) -import PlutusTx.AssocMap qualified as AssocMap import Sample.Shared ( governor, signer, @@ -64,52 +49,6 @@ import Sample.Shared ( ) import Test.Util (sortValue) --- | This script context should be a valid transaction. -stakeCreation :: ScriptContext -stakeCreation = - let st = assetClassValue stakeAssetClass 1 -- Stake ST - datum :: StakeDatum - datum = StakeDatum 424242424242 (PubKeyCredential signer) Nothing [] - - builder :: MintingBuilder - builder = - mconcat - [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - , signedWith signer - , mint st - , output $ - mconcat - [ script stakeValidatorHash - , withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242) - , withDatum datum - ] - , withMinting stakeSymbol - ] - in buildMinting' builder - --- | This ScriptContext should fail because the datum has too much GT. -stakeCreationWrongDatum :: ScriptContext -stakeCreationWrongDatum = - let datum :: Datum - datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 (PubKeyCredential signer) Nothing []) -- Too much GT - in ScriptContext - { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = AssocMap.fromList [("", datum)]} - , scriptContextPurpose = Minting stakeSymbol - } - --- | This ScriptContext should fail because the datum has too much GT. -stakeCreationUnsigned :: ScriptContext -stakeCreationUnsigned = - ScriptContext - { scriptContextTxInfo = - stakeCreation.scriptContextTxInfo - { txInfoSignatories = [] - } - , scriptContextPurpose = Minting stakeSymbol - } - --------------------------------------------------------------------------------- - -- | Config for creating a ScriptContext that deposits or withdraws. data DepositWithdrawExample = DepositWithdrawExample { startAmount :: Tagged GTTag Integer diff --git a/agora-specs/Sample/Stake/Create.hs b/agora-specs/Sample/Stake/Create.hs new file mode 100644 index 0000000..40266df --- /dev/null +++ b/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] + } + } diff --git a/agora-specs/Sample/Stake/Destroy.hs b/agora-specs/Sample/Stake/Destroy.hs new file mode 100644 index 0000000..451c208 --- /dev/null +++ b/agora-specs/Sample/Stake/Destroy.hs @@ -0,0 +1,297 @@ +module Sample.Stake.Destroy ( + ParameterBundle (..), + StakeInputParameters (..), + StakeBurningParameters (..), + LeftOverStakeMode (..), + AuthorizedBy (..), + Validity (..), + destroy, + mkTestTree, + mkTotallyValid, + oneStake, + multipleStakes, + stealSST, + stealSST1, + stealSST3, + lockedStakes, + authorizedByDelegatee, + notAuthorized, +) where + +import Agora.Proposal (ProposalId (..)) +import Agora.Stake ( + ProposalLock (Created), + StakeDatum (..), + StakeRedeemer (Destroy), + ) +import Control.Exception (assert) +import Data.Maybe (catMaybes, fromJust) +import Data.Semigroup (stimesMonoid) +import Plutarch.Context ( + input, + mint, + normalizeValue, + output, + pubKey, + script, + signedWith, + withDatum, + withRedeemer, + withRef, + withValue, + ) +import Plutarch.Extra.AssetClass (assetClassValue) +import PlutusLedgerApi.V1 ( + Credential (PubKeyCredential), + TxOutRef (TxOutRef), + ) +import PlutusLedgerApi.V2 (PubKeyHash) +import Sample.Proposal.Shared (stakeTxRef) +import Sample.Shared ( + minAda, + signer2, + stakeAssetClass, + stakePolicy, + stakeSymbol, + stakeValidator, + stakeValidatorHash, + ) +import Test.Specification ( + SpecificationTree, + group, + testPolicy, + testValidator, + ) +import Test.Util (CombinableBuilder, mkMinting, mkSpending, pubKeyHashes) + +data ParameterBundle = ParameterBundle + { stakeInputParameters :: StakeInputParameters + , stakeBurningParameters :: StakeBurningParameters + , authorizedBy :: AuthorizedBy + } + +data StakeInputParameters = StakeInputParameters + { numInputs :: Int + , notUnlocked :: Bool + } + +data StakeBurningParameters = StakeBurningParameters + { numBurnt :: Int + , leftOverStakeMode :: Maybe LeftOverStakeMode + } + +data LeftOverStakeMode = OutputAsIs | CollectSSTInOneUTxO + +data AuthorizedBy = Owner | Delegatee | NotAuthorized + +data Validity = Validity + { forStakePolicy :: Maybe Bool + , forStakeValidator :: Bool + } + +-------------------------------------------------------------------------------- + +owner :: PubKeyHash +owner = pubKeyHashes !! 2 + +delegatee :: PubKeyHash +delegatee = pubKeyHashes !! 3 + +-------------------------------------------------------------------------------- + +mkStakeInputDatum :: StakeInputParameters -> StakeDatum +mkStakeInputDatum ps = + StakeDatum + { stakedAmount = 114514 + , owner = PubKeyCredential owner + , delegatedTo = Just $ PubKeyCredential delegatee + , lockedBy = [Created $ ProposalId 0 | ps.notUnlocked] + } + +mkStakeRef :: Int -> TxOutRef +mkStakeRef = TxOutRef stakeTxRef . fromIntegral + +stakeRedeemer :: StakeRedeemer +stakeRedeemer = Destroy + +-------------------------------------------------------------------------------- + +destroy :: forall b. CombinableBuilder b => ParameterBundle -> b +destroy ps = + let stakeInputDatum = mkStakeInputDatum ps.stakeInputParameters + + sst = assetClassValue stakeAssetClass 1 + + stakeUTxOTemplate = + mconcat + [ script stakeValidatorHash + , withDatum stakeInputDatum + , withValue $ normalizeValue $ sst <> minAda + ] + + stakeInputBuilder = + foldMap + ( \i -> + input $ + mconcat + [ stakeUTxOTemplate + , withRef $ mkStakeRef i + , withRedeemer stakeRedeemer + ] + ) + [1 .. ps.stakeInputParameters.numInputs] + + withSSTsBurnt = + mint $ + normalizeValue $ + assetClassValue stakeAssetClass $ + negate $ + fromIntegral ps.stakeBurningParameters.numBurnt + + --- + + leftOverStakes = + ps.stakeInputParameters.numInputs + - ps.stakeBurningParameters.numBurnt + + stealSSTs = + case fromJust ps.stakeBurningParameters.leftOverStakeMode of + OutputAsIs -> + foldMap output $ + replicate + leftOverStakes + stakeUTxOTemplate + CollectSSTInOneUTxO -> + output $ + mconcat + [ pubKey signer2 + , withValue $ stimesMonoid leftOverStakes sst + ] + + stakeOutputBuilder = + assert (leftOverStakes >= 0) $ + mconcat + [ withSSTsBurnt + , if leftOverStakes > 0 + then stealSSTs + else mempty + ] + + --- + + sigBuilder = case ps.authorizedBy of + Owner -> signedWith owner + Delegatee -> signedWith delegatee + NotAuthorized -> mempty + in mconcat + [ stakeInputBuilder + , stakeOutputBuilder + , sigBuilder + ] + +-------------------------------------------------------------------------------- + +mkTestTree :: + String -> + ParameterBundle -> + Validity -> + SpecificationTree +mkTestTree name pb val = group name $ catMaybes [validator, policy] + where + spend = mkSpending destroy pb + mint = mkMinting destroy pb + validator = + Just $ + testValidator + val.forStakeValidator + "stake validator" + stakeValidator + (mkStakeInputDatum pb.stakeInputParameters) + stakeRedeemer + (spend $ mkStakeRef 1) + + policy = case pb.stakeBurningParameters.numBurnt of + 0 -> Nothing + _ -> + Just $ + testPolicy + (fromJust val.forStakePolicy) + "stake policy" + stakePolicy + () + (mint stakeSymbol) + +-------------------------------------------------------------------------------- + +mkTotallyValid :: Int -> ParameterBundle +mkTotallyValid numStakes = + ParameterBundle + { stakeInputParameters = + StakeInputParameters + { numInputs = numStakes + , notUnlocked = False + } + , stakeBurningParameters = + StakeBurningParameters + { numBurnt = numStakes + , leftOverStakeMode = Nothing + } + , authorizedBy = Owner + } + +oneStake :: ParameterBundle +oneStake = mkTotallyValid 1 + +multipleStakes :: ParameterBundle +multipleStakes = mkTotallyValid 10 + +stealSST :: ParameterBundle +stealSST = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 1 + , leftOverStakeMode = Just CollectSSTInOneUTxO + } + } + +stealSST1 :: ParameterBundle +stealSST1 = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 0 + , leftOverStakeMode = Just CollectSSTInOneUTxO + } + } + +stealSST3 :: ParameterBundle +stealSST3 = + multipleStakes + { stakeBurningParameters = + StakeBurningParameters + { numBurnt = 1 + , leftOverStakeMode = Just OutputAsIs + } + } + +lockedStakes :: ParameterBundle +lockedStakes = + multipleStakes + { stakeInputParameters = + multipleStakes.stakeInputParameters + { notUnlocked = True + } + } + +authorizedByDelegatee :: ParameterBundle +authorizedByDelegatee = + multipleStakes + { authorizedBy = Delegatee + } + +notAuthorized :: ParameterBundle +notAuthorized = + multipleStakes + { authorizedBy = NotAuthorized + } diff --git a/agora-specs/Spec/Proposal.hs b/agora-specs/Spec/Proposal.hs index 61049e3..dd82c4f 100644 --- a/agora-specs/Spec/Proposal.hs +++ b/agora-specs/Spec/Proposal.hs @@ -10,6 +10,7 @@ module Spec.Proposal (specs) where import Sample.Proposal.Advance qualified as Advance import Sample.Proposal.Cosign qualified as Cosign import Sample.Proposal.Create qualified as Create +import Sample.Proposal.PrivilegeEscalate qualified as PrivilegeEscalate import Sample.Proposal.Unlock qualified as Unlock import Sample.Proposal.Vote qualified as Vote @@ -397,4 +398,15 @@ specs = illegalGroup = group "illegal" $ map mkIllegalGroup stakeCountCases in [legalGroup, illegalGroup] ] + , group + "privilege escalate" + [ PrivilegeEscalate.mkTestTree + "vote" + PrivilegeEscalate.Voting + (PrivilegeEscalate.Validity False False) + , PrivilegeEscalate.mkTestTree + "retract votes" + PrivilegeEscalate.RetractingVotes + (PrivilegeEscalate.Validity False False) + ] ] diff --git a/agora-specs/Spec/Stake.hs b/agora-specs/Spec/Stake.hs index 7e62929..ae26e88 100644 --- a/agora-specs/Spec/Stake.hs +++ b/agora-specs/Spec/Stake.hs @@ -13,10 +13,8 @@ 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.Shared (stakeValidator) import Sample.Stake ( DepositWithdrawExample ( DepositWithdrawExample, @@ -26,46 +24,117 @@ import Sample.Stake ( signer, ) import Sample.Stake qualified as Stake ( - stakeCreation, - stakeCreationUnsigned, - stakeCreationWrongDatum, stakeDepositWithdraw, ) +import Sample.Stake.Create qualified as Create +import Sample.Stake.Destroy qualified as Destroy import Sample.Stake.SetDelegate qualified as SetDelegate import Test.Specification ( SpecificationTree, group, - policyFailsWith, - policySucceedsWith, validatorFailsWith, validatorSucceedsWith, ) -import Prelude (Num (negate), ($)) -- | The SpecificationTree exported by this module. specs :: [SpecificationTree] specs = [ group "policy" - [ policySucceedsWith - "stakeCreation" - stakePolicy - () - Stake.stakeCreation - , policyFailsWith - "stakeCreationWrongDatum" - stakePolicy - () - Stake.stakeCreationWrongDatum - , policyFailsWith - "stakeCreationUnsigned" - stakePolicy - () - Stake.stakeCreationUnsigned + [ 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 + ] + ] ] , group "validator" - [ validatorSucceedsWith + [ group + "destroy" + [ group + "legal" + [ Destroy.mkTestTree + "One stake" + Destroy.oneStake + (Destroy.Validity (Just True) True) + , Destroy.mkTestTree + "Multiple stake" + Destroy.multipleStakes + (Destroy.Validity (Just True) True) + ] + , group + "illegal" + [ Destroy.mkTestTree + "Destroy only one stake to steal SST" + Destroy.stealSST + (Destroy.Validity (Just False) False) + , Destroy.mkTestTree + "Destroy nothing to steal SST" + Destroy.stealSST1 + (Destroy.Validity Nothing False) + , Destroy.mkTestTree + "Steal SST" + Destroy.stealSST3 + (Destroy.Validity (Just False) False) + , Destroy.mkTestTree + "Destroy locked stakes" + Destroy.lockedStakes + (Destroy.Validity (Just True) False) + , Destroy.mkTestTree + "not authorized by owner" + Destroy.notAuthorized + (Destroy.Validity (Just True) False) + , Destroy.mkTestTree + "not authorized by owner" + Destroy.authorizedByDelegatee + (Destroy.Validity (Just True) False) + ] + ] + , validatorSucceedsWith "stakeDepositWithdraw deposit" stakeValidator (StakeDatum 100_000 (PubKeyCredential signer) Nothing []) diff --git a/agora.cabal b/agora.cabal index a1961b3..8eb2209 100644 --- a/agora.cabal +++ b/agora.cabal @@ -199,11 +199,14 @@ library agora-specs Sample.Proposal.Advance Sample.Proposal.Cosign Sample.Proposal.Create + Sample.Proposal.PrivilegeEscalate Sample.Proposal.Shared Sample.Proposal.Unlock Sample.Proposal.Vote Sample.Shared Sample.Stake + Sample.Stake.Create + Sample.Stake.Destroy Sample.Stake.SetDelegate Sample.Treasury Spec.AuthorityToken diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 6aae378..6b1410c 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -43,7 +43,6 @@ import Agora.Stake ( PStakeRedeemerHandlerContext ), StakeRedeemerImpl (..), - pstakeLocked, ) import Agora.Stake.Redeemers ( pclearDelegate, @@ -53,7 +52,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 +72,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 ( @@ -151,26 +150,16 @@ stakePolicy = pto $ pfoldMap @_ @_ @(PSum PInteger) # plam - ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do - txOutF <- pletFieldsC @'["value", "datum"] txOut - + ( \((pfield @"resolved" #) -> txOut) -> let isStakeUTxO = - psymbolValueOf # ownSymbol # txOutF.value #== 1 - - pmatchC isStakeUTxO - >>= \case - PTrue -> do - let datum = - pfromData $ - pfromOutputDatum @(PAsData PStakeDatum) - # txOutF.datum - # txInfoF.datums - - pguardC "Stake is unlocked" $ - pnot # (pstakeLocked # datum) - - pure $ pcon $ PSum 1 - PFalse -> pure mempty + psymbolValueOf + # ownSymbol + # (pfield @"value" # txOut) + #== 1 + in pif + isStakeUTxO + (pcon $ PSum 1) + mempty ) # pfromData txInfoF.inputs @@ -207,24 +196,31 @@ stakePolicy = # pfromData txInfoF.outputs outputF <- - pletFieldsC @'["value", "address", "datum"] scriptOutputWithStakeST - datumF <- - pletFieldsC @'["owner", "stakedAmount"] $ - pto $ - pfromData $ - pfromOutputDatum @(PAsData PStakeDatum) # outputF.datum # txInfoF.datums + pletFieldsC @'["value", "datum"] + scriptOutputWithStakeST - let hasExpectedStake = - ptraceIfFalse "Stake ouput has expected amount of stake token" $ + datumF <- + 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 - - pure $ hasExpectedStake #&& ownerSignsTransaction + , ptraceIfFalse "Initial delegatee should set to nothing" $ + pisDNothing # datumF.delegatedTo + , ptraceIfFalse "Initial locks should be empty" $ + pnull # pfromData datumF.lockedBy + ] pure $ popaque (pconstant ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index be892d7..6227265 100644 --- a/agora/Agora/Utils.hs +++ b/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 diff --git a/bench.csv b/bench.csv index 3117416..bc58aee 100644 --- a/bench.csv +++ b/bench.csv @@ -4,7 +4,15 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,300492604,786706,4250 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,123980615,348263,11521 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,145816056,387807,4684 -Agora/Stake/policy/stakeCreation,59498953,158188,3481 +Agora/Stake/policy/create/valid/stake owner: pub key,76591830,196946,3583 +Agora/Stake/policy/create/valid/stake owner: script,89731086,235525,3618 +Agora/Stake/validator/destroy/legal/One stake/stake validator,107112511,299069,7414 +Agora/Stake/validator/destroy/legal/One stake/stake policy,42685276,121860,3570 +Agora/Stake/validator/destroy/legal/Multiple stake/stake validator,693758152,1779821,10667 +Agora/Stake/validator/destroy/legal/Multiple stake/stake policy,418433413,1153422,6822 +Agora/Stake/validator/destroy/illegal/Destroy locked stakes/stake policy,418433413,1153422,6883 +Agora/Stake/validator/destroy/illegal/not authorized by owner/stake policy,418433413,1153422,6791 +Agora/Stake/validator/destroy/illegal/not authorized by owner/stake policy,418433413,1153422,6822 Agora/Stake/validator/stakeDepositWithdraw deposit,147174364,403343,7529 Agora/Stake/validator/stakeDepositWithdraw withdraw,147174364,403343,7521 Agora/Stake/validator/set delegate/override existing delegate,179507112,476672,7660