Merge branch 'staging' into seungheonoh/updatepse
This commit is contained in:
SeungheonOh
GitHub
commit
dac9dc2394
42 changed files with 2344 additions and 1716 deletions
|
|
@ -1,3 +1,7 @@
|
|||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Redundant bracket" #-}
|
||||
|
||||
{- |
|
||||
Module : Property.Governor
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
|
|
@ -7,19 +11,35 @@ Property model and tests for 'Governor' related functions
|
|||
-}
|
||||
module Property.Governor (props) where
|
||||
|
||||
import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
|
||||
import Agora.Governor (
|
||||
GovernorDatum (
|
||||
GovernorDatum,
|
||||
createProposalTimeRangeMaxWidth,
|
||||
maximumCreatedProposalsPerStake,
|
||||
nextProposalId,
|
||||
proposalThresholds,
|
||||
proposalTimings
|
||||
),
|
||||
PGovernorDatum,
|
||||
pisGovernorDatumValid,
|
||||
)
|
||||
import Agora.Governor.Scripts (governorPolicy)
|
||||
import Agora.Proposal (
|
||||
ProposalId (ProposalId),
|
||||
ProposalThresholds (ProposalThresholds),
|
||||
ProposalThresholds (
|
||||
ProposalThresholds
|
||||
),
|
||||
)
|
||||
import Agora.Proposal.Time (
|
||||
MaxTimeRangeWidth (MaxTimeRangeWidth),
|
||||
ProposalTimingConfig (ProposalTimingConfig),
|
||||
)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Default (def)
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Data.Universe (Finite (..), Universe (..))
|
||||
import Data.Universe (Universe)
|
||||
import Data.Universe.Class (Finite)
|
||||
import Generics.SOP.NP (NP (Nil, (:*)))
|
||||
import Optics (view)
|
||||
import Plutarch.Api.V2 (PScriptContext)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -34,31 +54,42 @@ import Plutarch.Context (
|
|||
withRef,
|
||||
withValue,
|
||||
)
|
||||
import Plutarch.Evaluate (evalTerm)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import PlutusLedgerApi.V2 (
|
||||
ScriptContext (scriptContextTxInfo),
|
||||
TxInInfo (txInInfoOutRef),
|
||||
TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
|
||||
TxOut (txOutValue),
|
||||
import Plutarch.Extra.Compile (mustCompile)
|
||||
import Plutarch.Test.QuickCheck (
|
||||
Equality (OnPEq),
|
||||
Partiality (ByComplete),
|
||||
TestableTerm (TestableTerm),
|
||||
haskEquiv,
|
||||
pconstantT,
|
||||
shouldCrash,
|
||||
shouldRun,
|
||||
)
|
||||
import PlutusLedgerApi.V2 (Script, ScriptContext)
|
||||
import Property.Generator (genInput, genOutput)
|
||||
import Sample.Shared (
|
||||
deterministicTracingConfig,
|
||||
governor,
|
||||
governorAssetClass,
|
||||
governorSymbol,
|
||||
governorValidatorHash,
|
||||
gstUTXORef,
|
||||
)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
|
||||
import Test.Tasty.QuickCheck (
|
||||
import Test.QuickCheck (
|
||||
Arbitrary (arbitrary),
|
||||
Gen,
|
||||
Property,
|
||||
arbitraryBoundedEnum,
|
||||
checkCoverage,
|
||||
choose,
|
||||
chooseInteger,
|
||||
cover,
|
||||
forAll,
|
||||
listOf1,
|
||||
testProperty,
|
||||
)
|
||||
import Test.Tasty (TestTree, adjustOption, testGroup)
|
||||
import Test.Tasty.QuickCheck (QuickCheckTests, testProperty)
|
||||
|
||||
data GovernorDatumCases
|
||||
= ExecuteLE0
|
||||
|
|
@ -67,172 +98,211 @@ data GovernorDatumCases
|
|||
| VoteLE0
|
||||
| CosignLE0
|
||||
| Correct
|
||||
deriving stock (Eq, Show)
|
||||
deriving stock (Eq, Show, Enum, Bounded)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
instance Universe GovernorDatumCases where
|
||||
universe =
|
||||
[ ExecuteLE0
|
||||
, CreateLE0
|
||||
, VoteLE0
|
||||
, CosignLE0
|
||||
, Correct
|
||||
]
|
||||
instance Arbitrary GovernorDatumCases where
|
||||
arbitrary = arbitraryBoundedEnum
|
||||
|
||||
instance Finite GovernorDatumCases where
|
||||
universeF = universe
|
||||
cardinality = Tagged 6
|
||||
|
||||
{- | Property that checks `governorDatumValid`.
|
||||
`governorDatumValid` determines if given governor datum is valid or not. This property
|
||||
ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum.
|
||||
{- | Property that checks `pisGovernorDatumValid` behaves as intended by
|
||||
comparing it to a simple haskell implementation.
|
||||
-}
|
||||
governorDatumValidProperty :: Property
|
||||
governorDatumValidProperty =
|
||||
classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
|
||||
haskEquiv @( 'OnPEq) @( 'ByComplete)
|
||||
isValidModelImpl
|
||||
(TestableTerm pisGovernorDatumValid)
|
||||
(genDatum :* Nil)
|
||||
where
|
||||
classifier :: GovernorDatum -> GovernorDatumCases
|
||||
classifier
|
||||
( (.proposalThresholds) ->
|
||||
ProposalThresholds
|
||||
execute
|
||||
create
|
||||
toVoting
|
||||
vote
|
||||
cosign
|
||||
)
|
||||
| execute < 0 = ExecuteLE0
|
||||
| create < 0 = CreateLE0
|
||||
| toVoting < 0 = ToVotingLE0
|
||||
| vote < 0 = VoteLE0
|
||||
| cosign < 0 = CosignLE0
|
||||
| otherwise = Correct
|
||||
|
||||
expected :: GovernorDatum -> Maybe Bool
|
||||
expected c = Just $ classifier c == Correct
|
||||
|
||||
gen :: GovernorDatumCases -> Gen GovernorDatum
|
||||
gen c = do
|
||||
thres <- genProposalThresholds c
|
||||
|
||||
let timing = ProposalTimingConfig 0 0 0 0
|
||||
return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
|
||||
genDatum :: Gen (TestableTerm PGovernorDatum)
|
||||
genDatum = pconstantT <$> (arbitrary >>= genDatumForCase)
|
||||
where
|
||||
taggedInteger p = Tagged <$> chooseInteger p
|
||||
genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
|
||||
genProposalThresholds c = do
|
||||
let validGT = taggedInteger (0, 1000000000)
|
||||
execute <- validGT
|
||||
create <- validGT
|
||||
toVoting <- validGT
|
||||
vote <- validGT
|
||||
cosign <- validGT
|
||||
le0 <- taggedInteger (-1000, -1)
|
||||
genDatumForCase :: GovernorDatumCases -> Gen GovernorDatum
|
||||
genDatumForCase c = do
|
||||
thres <- genProposalThresholds c
|
||||
|
||||
case c of
|
||||
ExecuteLE0 ->
|
||||
-- execute < 0
|
||||
return $ ProposalThresholds le0 create toVoting vote cosign
|
||||
CreateLE0 ->
|
||||
-- c < 0
|
||||
return $ ProposalThresholds execute le0 toVoting vote cosign
|
||||
ToVotingLE0 ->
|
||||
return $ ProposalThresholds execute create le0 vote cosign
|
||||
VoteLE0 ->
|
||||
-- vote < 0
|
||||
return $ ProposalThresholds execute create toVoting le0 cosign
|
||||
CosignLE0 ->
|
||||
return $ ProposalThresholds execute create toVoting vote le0
|
||||
Correct ->
|
||||
return $ ProposalThresholds execute create toVoting vote cosign
|
||||
let timing = ProposalTimingConfig 0 0 0 0 0 0
|
||||
pure $
|
||||
GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
|
||||
where
|
||||
taggedInteger p = Tagged <$> chooseInteger p
|
||||
genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
|
||||
genProposalThresholds c = do
|
||||
let validGT = taggedInteger (0, 1000000000)
|
||||
execute <- validGT
|
||||
create <- validGT
|
||||
toVoting <- validGT
|
||||
vote <- validGT
|
||||
cosign <- validGT
|
||||
le0 <- taggedInteger (-1000, -1)
|
||||
|
||||
case c of
|
||||
ExecuteLE0 ->
|
||||
-- execute < 0
|
||||
return $ ProposalThresholds le0 create toVoting vote cosign
|
||||
CreateLE0 ->
|
||||
-- c < 0
|
||||
return $ ProposalThresholds execute le0 toVoting vote cosign
|
||||
ToVotingLE0 ->
|
||||
return $ ProposalThresholds execute create le0 vote cosign
|
||||
VoteLE0 ->
|
||||
-- vote < 0
|
||||
return $ ProposalThresholds execute create toVoting le0 cosign
|
||||
CosignLE0 ->
|
||||
return $ ProposalThresholds execute create toVoting vote le0
|
||||
Correct ->
|
||||
return $ ProposalThresholds execute create toVoting vote cosign
|
||||
|
||||
-- \| This is a model Haskell implementation of `pisGovernorDatumValid`.
|
||||
isValidModelImpl :: GovernorDatum -> Bool
|
||||
isValidModelImpl = correctCase . classifier
|
||||
where
|
||||
correctCase = \case
|
||||
Correct -> True
|
||||
_ -> False
|
||||
|
||||
classifier :: GovernorDatum -> GovernorDatumCases
|
||||
classifier
|
||||
( view #proposalThresholds ->
|
||||
ProposalThresholds
|
||||
execute
|
||||
create
|
||||
toVoting
|
||||
vote
|
||||
cosign
|
||||
)
|
||||
| execute < 0 = ExecuteLE0
|
||||
| create < 0 = CreateLE0
|
||||
| toVoting < 0 = ToVotingLE0
|
||||
| vote < 0 = VoteLE0
|
||||
| cosign < 0 = CosignLE0
|
||||
| otherwise = Correct
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data GovernorPolicyCases
|
||||
= ReferenceUTXONotSpent
|
||||
| IncorrectAmountOfTokenMinted
|
||||
| GovernorOutputNotFound
|
||||
| GovernorPolicyCorrect
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance Universe GovernorPolicyCases where
|
||||
universe =
|
||||
[ ReferenceUTXONotSpent
|
||||
, IncorrectAmountOfTokenMinted
|
||||
, GovernorOutputNotFound
|
||||
, GovernorPolicyCorrect
|
||||
]
|
||||
governorMintingPolicyTests :: [TestTree]
|
||||
governorMintingPolicyTests =
|
||||
[ mkGovMintingCasePropertyTest
|
||||
"Reference input spend test"
|
||||
ReferenceUTXONotSpent
|
||||
"Spent"
|
||||
"Not spent"
|
||||
, mkGovMintingCasePropertyTest
|
||||
"Amount of token minted test"
|
||||
IncorrectAmountOfTokenMinted
|
||||
"Correct"
|
||||
"Incorrect"
|
||||
, mkGovMintingCasePropertyTest
|
||||
"Governor output presense"
|
||||
GovernorOutputNotFound
|
||||
"Present"
|
||||
"Absent"
|
||||
]
|
||||
|
||||
instance Finite GovernorPolicyCases where
|
||||
universeF = universe
|
||||
cardinality = Tagged 4
|
||||
{- | Creates a property by compiling governorPolicy script with given arguments
|
||||
and checking if it runs as expected by a test.
|
||||
-}
|
||||
governorPolicyValid :: ScriptContext -> Bool -> Property
|
||||
governorPolicyValid ctx shouldSucceed =
|
||||
let mp = mkPolicyScript ctx in if shouldSucceed then shouldRun mp else shouldCrash mp
|
||||
|
||||
governorMintingProperty :: Property
|
||||
governorMintingProperty =
|
||||
classifiedPropertyNative gen (const []) expected classifier actual
|
||||
{-# INLINEABLE mkPolicyScript #-}
|
||||
mkPolicyScript :: ScriptContext -> Script
|
||||
mkPolicyScript ctx = mustCompile (go # pconstant ctx)
|
||||
where
|
||||
{- Note:
|
||||
I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function.
|
||||
-}
|
||||
gst = assetClassValue governorAssetClass 1
|
||||
mintAmount x = mint . mconcat $ replicate x gst
|
||||
outputToGov =
|
||||
output $
|
||||
mconcat
|
||||
[ script governorValidatorHash
|
||||
, withValue gst
|
||||
, withDatum govDatum
|
||||
]
|
||||
referencedInput = input $ withRef gstUTXORef
|
||||
go :: forall (s :: S). Term s (PScriptContext :--> POpaque)
|
||||
go = loudEval $
|
||||
plam $ \sc ->
|
||||
governorPolicy
|
||||
# pconstant (view #gstOutRef governor)
|
||||
# pforgetData (pconstantData ())
|
||||
# sc
|
||||
|
||||
govDatum :: GovernorDatum
|
||||
govDatum =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = def
|
||||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
}
|
||||
|
||||
gen :: GovernorPolicyCases -> Gen ScriptContext
|
||||
-- | Prepares a minting policy test for given policy error case.
|
||||
mkGovMintingCasePropertyTest ::
|
||||
String ->
|
||||
GovernorPolicyCases ->
|
||||
String ->
|
||||
String ->
|
||||
TestTree
|
||||
mkGovMintingCasePropertyTest name case' positiveCaseName negativeCaseName =
|
||||
testProperty name $
|
||||
forAll (gen case') $
|
||||
\(ctx, valid) ->
|
||||
checkCoverage $
|
||||
cover 48 valid positiveCaseName $
|
||||
cover 48 (not valid) negativeCaseName $
|
||||
governorPolicyValid ctx valid
|
||||
where
|
||||
gen :: GovernorPolicyCases -> Gen (ScriptContext, Bool)
|
||||
gen c = do
|
||||
inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder
|
||||
outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder
|
||||
toks <- choose (2, 100)
|
||||
|
||||
valid <- arbitrary
|
||||
let comp =
|
||||
case c of
|
||||
ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
|
||||
IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks
|
||||
GovernorOutputNotFound -> referencedInput <> mintAmount 1
|
||||
GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1
|
||||
if valid
|
||||
then referencedInput <> outputToGov <> mintAmount 1
|
||||
else case c of
|
||||
ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
|
||||
IncorrectAmountOfTokenMinted ->
|
||||
referencedInput
|
||||
<> outputToGov
|
||||
<> mintAmount toks
|
||||
GovernorOutputNotFound -> referencedInput <> mintAmount 1
|
||||
|
||||
return . buildMinting' $ inputs <> outputs <> comp <> withMinting governorSymbol
|
||||
|
||||
expected :: ScriptContext -> Maybe ()
|
||||
expected sc =
|
||||
case classifier sc of
|
||||
GovernorPolicyCorrect -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
opaqueToUnit :: Term s (POpaque :--> PUnit)
|
||||
opaqueToUnit = plam $ \_ -> pconstant ()
|
||||
|
||||
actual :: Term s (PScriptContext :--> PUnit)
|
||||
actual = plam $ \sc -> opaqueToUnit #$ governorPolicy # pconstant governor.gstOutRef # pforgetData (pconstantData ()) # sc
|
||||
|
||||
classifier :: ScriptContext -> GovernorPolicyCases
|
||||
classifier sc
|
||||
| minted /= gst = IncorrectAmountOfTokenMinted
|
||||
| refInputNotExists = ReferenceUTXONotSpent
|
||||
| govOutputNotExists = GovernorOutputNotFound
|
||||
| otherwise = GovernorPolicyCorrect
|
||||
let ctx =
|
||||
buildMinting' $
|
||||
inputs
|
||||
<> outputs
|
||||
<> comp
|
||||
<> withMinting
|
||||
governorSymbol
|
||||
pure (ctx, valid)
|
||||
where
|
||||
txinfo = scriptContextTxInfo sc
|
||||
minted = txInfoMint txinfo
|
||||
refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
|
||||
govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
|
||||
govDatum :: GovernorDatum
|
||||
govDatum =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = def
|
||||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
||||
gst = assetClassValue governorAssetClass 1
|
||||
mintAmount x = mint . mconcat $ replicate x gst
|
||||
referencedInput = input $ withRef gstUTXORef
|
||||
outputToGov =
|
||||
output $
|
||||
mconcat
|
||||
[ script governorValidatorHash
|
||||
, withValue gst
|
||||
, withDatum govDatum
|
||||
]
|
||||
|
||||
props :: [TestTree]
|
||||
props =
|
||||
[ testProperty "governorDatumValid" governorDatumValidProperty
|
||||
, testProperty "governorPolicy" governorMintingProperty
|
||||
[ adjustOption go . testProperty "governorDatumValid" $ governorDatumValidProperty
|
||||
, testGroup "governorPolicy" governorMintingPolicyTests
|
||||
]
|
||||
where
|
||||
go :: QuickCheckTests -> QuickCheckTests
|
||||
go = max 20_000
|
||||
|
||||
loudEval ::
|
||||
forall (p :: S -> Type).
|
||||
ClosedTerm p ->
|
||||
ClosedTerm p
|
||||
loudEval x =
|
||||
case evalTerm deterministicTracingConfig x of
|
||||
Right (Right t, _, _) -> t
|
||||
Right (Left err, _, trace) -> error $ show err <> show trace
|
||||
Left err -> error $ show err
|
||||
|
|
|
|||
|
|
@ -0,0 +1,66 @@
|
|||
module Sample.AuthorityToken.UnauthorizedMintingExploit (
|
||||
Parameters (..),
|
||||
exploit,
|
||||
mkTestCase,
|
||||
) where
|
||||
|
||||
import Control.Exception (assert)
|
||||
import Plutarch.Context (input, mint, normalizeValue, output, script, withValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda)
|
||||
import Test.Specification (SpecificationTree, testPolicy)
|
||||
import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
|
||||
|
||||
data Parameters = Parameters
|
||||
{ burntGAT :: Int
|
||||
, mintedGAT :: Int
|
||||
}
|
||||
|
||||
exploit ::
|
||||
forall b.
|
||||
CombinableBuilder b =>
|
||||
Parameters ->
|
||||
b
|
||||
exploit (Parameters burntGAT mintedGAT) =
|
||||
assert (burntGAT > mintedGAT && mintedGAT > 0) $
|
||||
effectInputBuilder <> maliciousGATOutputBuilder
|
||||
where
|
||||
(effectScriptHashes, rest) = splitAt burntGAT validatorHashes
|
||||
maliciousScripts = take mintedGAT rest
|
||||
|
||||
gatValue hash =
|
||||
Value.singleton
|
||||
authorityTokenSymbol
|
||||
(validatorHashToTokenName hash)
|
||||
|
||||
mkGATUTxO hash =
|
||||
mconcat
|
||||
[ script hash
|
||||
, withValue $ normalizeValue $ minAda <> gatValue hash 1
|
||||
]
|
||||
|
||||
effectInputBuilder =
|
||||
foldMap
|
||||
( \effectHash ->
|
||||
mconcat
|
||||
[ mint $ gatValue effectHash $ negate 1
|
||||
, input $ mkGATUTxO effectHash
|
||||
]
|
||||
)
|
||||
effectScriptHashes
|
||||
|
||||
maliciousGATOutputBuilder =
|
||||
foldMap
|
||||
( \scriptHash ->
|
||||
mconcat
|
||||
[ mint $ gatValue scriptHash 1
|
||||
, output $ mkGATUTxO scriptHash
|
||||
]
|
||||
)
|
||||
maliciousScripts
|
||||
|
||||
mkTestCase :: String -> Parameters -> SpecificationTree
|
||||
mkTestCase name ps =
|
||||
testPolicy False name authorityTokenPolicy () $
|
||||
mkMinting exploit ps authorityTokenSymbol
|
||||
|
|
@ -17,12 +17,12 @@ import Agora.Effect.GovernorMutation (
|
|||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Map ((!))
|
||||
import Data.Tagged (Tagged (..))
|
||||
import Plutarch.Api.V2 (validatorHash)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1 qualified as Interval (always)
|
||||
import PlutusLedgerApi.V1.Address (scriptHashAddress)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (
|
||||
|
|
@ -114,7 +114,7 @@ mkEffectTxInfo newGovDatum =
|
|||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
governorInputDatum :: Datum
|
||||
governorInputDatum = Datum $ toBuiltinData governorInputDatum'
|
||||
|
|
@ -186,7 +186,7 @@ validNewGovernorDatum =
|
|||
, nextProposalId = ProposalId 42
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
||||
invalidNewGovernorDatum :: GovernorDatum
|
||||
|
|
@ -199,5 +199,5 @@ invalidNewGovernorDatum =
|
|||
, nextProposalId = ProposalId 42
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ import PlutusLedgerApi.V2 (
|
|||
ValidatorHash,
|
||||
)
|
||||
import Sample.Shared (
|
||||
deterministicTracingConfing,
|
||||
deterministicTracingConfig,
|
||||
minAda,
|
||||
)
|
||||
import Sample.Shared qualified as Shared
|
||||
|
|
@ -72,7 +72,7 @@ data Parameters = Parameters
|
|||
-- ^ Whether the 'GovernorDatum.proposalThresholds' field of the output
|
||||
-- governor datum is valid or not.
|
||||
, datumMaxTimeRangeWidthValid :: Bool
|
||||
-- ^ Whether the 'GovernorDatum.maximumProposalsPerStake'field of the
|
||||
-- ^ Whether the 'GovernorDatum.maximumCreatedProposalsPerStake'field of the
|
||||
-- output governor datum is valid or not.
|
||||
, datumTimingConfigValid :: Bool
|
||||
-- ^ Whether the 'GovernorDatum.proposalTimings'field of the output
|
||||
|
|
@ -96,7 +96,7 @@ validGovernorOutputDatum =
|
|||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
||||
invalidProposalThresholds :: ProposalThresholds
|
||||
|
|
@ -106,7 +106,7 @@ invalidMaxTimeRangeWidth :: MaxTimeRangeWidth
|
|||
invalidMaxTimeRangeWidth = MaxTimeRangeWidth 0
|
||||
|
||||
invalidProposalTimings :: ProposalTimingConfig
|
||||
invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1)
|
||||
invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1) (-1) (-1)
|
||||
|
||||
witnessRef :: TxOutRef
|
||||
witnessRef = TxOutRef "b0353c22b0bd6c5296a8eef160ba25d90b5dc82a9bb8bdaa6823ffc19515d6ad" 0
|
||||
|
|
@ -124,7 +124,7 @@ scripts =
|
|||
(fmap (view #script) . view #scripts)
|
||||
( runLinker
|
||||
linker
|
||||
(agoraScripts deterministicTracingConfing)
|
||||
(agoraScripts deterministicTracingConfig)
|
||||
governor
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ module Sample.Governor.Mutate (
|
|||
|
||||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
|
||||
import Agora.Utils (scriptHashToTokenName)
|
||||
import Data.Default (def)
|
||||
import Data.Map ((!))
|
||||
import Plutarch.Api.V2 (PMintingPolicy, mintingPolicySymbol, mkMintingPolicy, validatorHash)
|
||||
|
|
@ -33,6 +32,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
|
|
@ -105,7 +105,7 @@ governorInputDatum =
|
|||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
||||
mkGovernorOutputDatum ::
|
||||
|
|
@ -115,7 +115,7 @@ mkGovernorOutputDatum DatumValid =
|
|||
Just $
|
||||
toData $
|
||||
governorInputDatum
|
||||
{ maximumProposalsPerStake = 4
|
||||
{ maximumCreatedProposalsPerStake = 4
|
||||
}
|
||||
mkGovernorOutputDatum ValueInvalid =
|
||||
let invalidProposalThresholds =
|
||||
|
|
|
|||
|
|
@ -35,12 +35,14 @@ module Sample.Proposal.Advance (
|
|||
mkMintGATsWithoutTagBundle,
|
||||
mkBadGovernorOutputDatumBundle,
|
||||
mkUnexpectedOutputStakeBundles,
|
||||
mkFastforwardToFinishBundles,
|
||||
mkBadGovernorRedeemerBundle,
|
||||
) where
|
||||
|
||||
import Agora.Governor (
|
||||
Governor (..),
|
||||
GovernorDatum (..),
|
||||
GovernorRedeemer (MintGATs),
|
||||
GovernorRedeemer (CreateProposal, MintGATs),
|
||||
)
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
|
|
@ -67,7 +69,6 @@ import Agora.SafeMoney (AuthorityTokenTag, GTTag)
|
|||
import Agora.Stake (
|
||||
StakeDatum (..),
|
||||
)
|
||||
import Agora.Utils (scriptHashToTokenName)
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Monad.State (execState, modify, when)
|
||||
import Data.Default (def)
|
||||
|
|
@ -85,10 +86,12 @@ import Plutarch.Context (
|
|||
timeRange,
|
||||
withDatum,
|
||||
withInlineDatum,
|
||||
withRedeemer,
|
||||
withRef,
|
||||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
|
||||
import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
|
|
@ -100,6 +103,7 @@ import PlutusLedgerApi.V2 (
|
|||
TxOutRef (TxOutRef),
|
||||
ValidatorHash,
|
||||
)
|
||||
import PlutusTx qualified
|
||||
import Sample.Proposal.Shared (
|
||||
governorTxRef,
|
||||
proposalTxRef,
|
||||
|
|
@ -164,9 +168,18 @@ data ParameterBundle = ParameterBundle
|
|||
}
|
||||
|
||||
-- | Everything about the generated governor stuff.
|
||||
newtype GovernorParameters = GovernorParameters
|
||||
data GovernorParameters = forall
|
||||
(redeemer :: Type)
|
||||
(predeemer :: PType).
|
||||
( PUnsafeLiftDecl predeemer
|
||||
, PLifted predeemer ~ redeemer
|
||||
, PIsData predeemer
|
||||
, PlutusTx.ToData redeemer
|
||||
) =>
|
||||
GovernorParameters
|
||||
{ invalidGovernorOutputDatum :: Bool
|
||||
-- ^ The output governor datum will be changed.
|
||||
, governorRedeemer :: redeemer
|
||||
}
|
||||
|
||||
-- | Everything about the generated authority token stuff.
|
||||
|
|
@ -278,7 +291,7 @@ mkVotes ps =
|
|||
|
||||
-- | The starting time of every generated proposal.
|
||||
proposalStartingTime :: POSIXTime
|
||||
proposalStartingTime = 0
|
||||
proposalStartingTime = 100
|
||||
|
||||
-- | Create the input proposal datum given the parameters.
|
||||
mkProposalInputDatum :: ProposalParameters -> ProposalDatum
|
||||
|
|
@ -413,14 +426,14 @@ governorInputDatum =
|
|||
, nextProposalId = ProposalId 42
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
, maximumCreatedProposalsPerStake = 3
|
||||
}
|
||||
|
||||
-- | Create the output governor datum given the parameters.
|
||||
mkGovernorOutputDatum :: GovernorParameters -> GovernorDatum
|
||||
mkGovernorOutputDatum ps =
|
||||
if ps.invalidGovernorOutputDatum
|
||||
then governorInputDatum {maximumProposalsPerStake = 15}
|
||||
then governorInputDatum {maximumCreatedProposalsPerStake = 15}
|
||||
else governorInputDatum
|
||||
|
||||
-- | Reference to the governor UTXO.
|
||||
|
|
@ -431,7 +444,7 @@ governorRef = TxOutRef governorTxRef 2
|
|||
governor validator.
|
||||
-}
|
||||
mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
|
||||
mkGovernorBuilder ps =
|
||||
mkGovernorBuilder ps@(GovernorParameters _ redeemer) =
|
||||
let gst = assetClassValue governorAssetClass 1
|
||||
value = sortValue $ gst <> minAda
|
||||
in mconcat
|
||||
|
|
@ -441,6 +454,7 @@ mkGovernorBuilder ps =
|
|||
, withValue value
|
||||
, withRef governorRef
|
||||
, withDatum governorInputDatum
|
||||
, withRedeemer redeemer
|
||||
]
|
||||
, output $
|
||||
mconcat
|
||||
|
|
@ -451,12 +465,6 @@ mkGovernorBuilder ps =
|
|||
]
|
||||
]
|
||||
|
||||
{- | The proposal redeemer used to spend the governor UTXO, which is always
|
||||
'MintGATs' in this case.
|
||||
-}
|
||||
governorRedeemer :: GovernorRedeemer
|
||||
governorRedeemer = MintGATs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- * Authority Token
|
||||
|
|
@ -537,16 +545,22 @@ mkTestTree name pb val =
|
|||
proposalInputDatum
|
||||
proposalRedeemer
|
||||
(spend proposalRef)
|
||||
|
||||
governor =
|
||||
maybe [] singleton $
|
||||
testValidator
|
||||
(fromJust val.forGovernorValidator)
|
||||
"governor"
|
||||
governorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
(spend governorRef)
|
||||
<$ pb.governorParameters
|
||||
maybe
|
||||
[]
|
||||
( singleton
|
||||
. ( \(GovernorParameters _ governorRedeemer) ->
|
||||
testValidator
|
||||
(fromJust val.forGovernorValidator)
|
||||
"governor"
|
||||
governorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
(spend governorRef)
|
||||
)
|
||||
)
|
||||
(pb.governorParameters)
|
||||
|
||||
authority = case pb.authorityTokenParameters of
|
||||
[] -> []
|
||||
|
|
@ -715,20 +729,20 @@ mkMockEffects useAuthScript n = effects
|
|||
effectsPerGroup
|
||||
(zip effectScripts effectMetadata)
|
||||
|
||||
numberOfVotesThatExceedsTheMinimumRequirement :: Integer
|
||||
numberOfVotesThatExceedsTheMinimumRequirement =
|
||||
untag (def @ProposalThresholds).execute + 1
|
||||
numberOfVotesThatJustMeetsTheMinimumRequirement :: Integer
|
||||
numberOfVotesThatJustMeetsTheMinimumRequirement =
|
||||
untag (def @ProposalThresholds).execute
|
||||
|
||||
mkWinnerVotes :: Index -> (Winner, Integer)
|
||||
mkWinnerVotes idx =
|
||||
( EffectAt idx
|
||||
, numberOfVotesThatExceedsTheMinimumRequirement
|
||||
, numberOfVotesThatJustMeetsTheMinimumRequirement
|
||||
)
|
||||
|
||||
ambiguousWinnerVotes :: (Winner, Integer)
|
||||
ambiguousWinnerVotes =
|
||||
( All
|
||||
, numberOfVotesThatExceedsTheMinimumRequirement
|
||||
, numberOfVotesThatJustMeetsTheMinimumRequirement
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -826,6 +840,7 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
|
|||
gov =
|
||||
GovernorParameters
|
||||
{ invalidGovernorOutputDatum = False
|
||||
, governorRedeemer = MintGATs
|
||||
}
|
||||
in b
|
||||
{ governorParameters = Just gov
|
||||
|
|
@ -1065,4 +1080,47 @@ mkBadGovernorOutputDatumBundle nCosigners nEffects =
|
|||
}
|
||||
where
|
||||
template = mkValidFromLockedBundle nCosigners nEffects
|
||||
gov = GovernorParameters True
|
||||
gov = GovernorParameters True MintGATs
|
||||
|
||||
mkBadGovernorRedeemerBundle ::
|
||||
Word ->
|
||||
Word ->
|
||||
ParameterBundle
|
||||
mkBadGovernorRedeemerBundle nCosigners nEffects =
|
||||
template
|
||||
{ governorParameters = Just gov
|
||||
}
|
||||
where
|
||||
template = mkValidFromLockedBundle nCosigners nEffects
|
||||
gov = GovernorParameters False CreateProposal
|
||||
|
||||
mkFastforwardToFinishBundles ::
|
||||
Word ->
|
||||
Word ->
|
||||
[ParameterBundle]
|
||||
mkFastforwardToFinishBundles nCosigners nEffects = updateTemplate <$> templates
|
||||
where
|
||||
templates = mkValidToFailedStateBundles nCosigners nEffects
|
||||
mkMaliciousTimRange =
|
||||
let lb = proposalStartingTime - 1
|
||||
dub =
|
||||
1
|
||||
+ proposalStartingTime
|
||||
+ (def :: ProposalTimingConfig).draftTime
|
||||
vub =
|
||||
dub
|
||||
+ (def :: ProposalTimingConfig).votingTime
|
||||
+ (def :: ProposalTimingConfig).lockingTime
|
||||
lub =
|
||||
vub
|
||||
+ (def :: ProposalTimingConfig).executingTime
|
||||
go Draft = (lb, dub)
|
||||
go VotingReady = (lb, vub)
|
||||
go Locked = (lb, lub)
|
||||
go Finished = error "cannot advance from Finished"
|
||||
in uncurry closedBoundedInterval . go
|
||||
updateTemplate template =
|
||||
template
|
||||
{ transactionTimeRange =
|
||||
mkMaliciousTimRange template.proposalParameters.fromStatus
|
||||
}
|
||||
|
|
|
|||
|
|
@ -40,7 +40,8 @@ import Agora.Proposal.Time (
|
|||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
ProposalLock (Cosigned, Created),
|
||||
ProposalAction (Cosigned, Created),
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote),
|
||||
)
|
||||
|
|
@ -196,7 +197,7 @@ mkStakeInputDatum ps =
|
|||
amount = mkStakeAmount sps.gtAmount
|
||||
owner = mkStakeOwner sps.stakeOwner
|
||||
locks = case sps.stakeOwner of
|
||||
Creator -> [Created defProposalId]
|
||||
Creator -> [ProposalLock defProposalId Created]
|
||||
_ -> []
|
||||
in StakeDatum
|
||||
{ stakedAmount = amount
|
||||
|
|
@ -212,7 +213,7 @@ mkStakeOuputDatum ps =
|
|||
locks =
|
||||
if sps.dontUpdateLocks
|
||||
then inpDatum.lockedBy
|
||||
else Cosigned defProposalId : inpDatum.lockedBy
|
||||
else ProposalLock defProposalId Cosigned : inpDatum.lockedBy
|
||||
in inpDatum {lockedBy = locks}
|
||||
|
||||
stakeRedeemer :: StakeRedeemer
|
||||
|
|
|
|||
|
|
@ -17,12 +17,19 @@ module Sample.Proposal.Create (
|
|||
timeRangeNotTightParameters,
|
||||
timeRangeNotClosedParameters,
|
||||
invalidProposalStatusParameters,
|
||||
fakeSSTParameters,
|
||||
wrongGovernorRedeemer,
|
||||
wrongGovernorRedeemer1,
|
||||
) where
|
||||
|
||||
import Agora.Governor (
|
||||
Governor (..),
|
||||
GovernorDatum (..),
|
||||
GovernorRedeemer (CreateProposal),
|
||||
GovernorRedeemer (
|
||||
CreateProposal,
|
||||
MintGATs,
|
||||
MutateGovernor
|
||||
),
|
||||
)
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (..),
|
||||
|
|
@ -40,7 +47,8 @@ import Agora.Proposal.Time (
|
|||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
ProposalLock (..),
|
||||
ProposalAction (Created, Voted),
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote),
|
||||
)
|
||||
|
|
@ -63,10 +71,14 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
POSIXTime (POSIXTime),
|
||||
POSIXTimeRange,
|
||||
Redeemer (Redeemer),
|
||||
ToData (toBuiltinData),
|
||||
TxOutRef (TxOutRef),
|
||||
always,
|
||||
)
|
||||
|
|
@ -85,6 +97,7 @@ import Sample.Shared (
|
|||
signer,
|
||||
signer2,
|
||||
stakeAssetClass,
|
||||
stakeSymbol,
|
||||
stakeValidator,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
|
|
@ -95,6 +108,7 @@ import Test.Util (
|
|||
mkMinting,
|
||||
mkSpending,
|
||||
sortValue,
|
||||
validatorHashes,
|
||||
)
|
||||
|
||||
-- | Parameters for creating a proposal.
|
||||
|
|
@ -115,11 +129,15 @@ data Parameters = Parameters
|
|||
-- ^ Is 'TxInfo.validTimeRange' closed?
|
||||
, proposalStatus :: ProposalStatus
|
||||
-- ^ The status of the newly created proposal.
|
||||
, fakeSST :: Bool
|
||||
-- ^ Whether to use SST that doesn't belong to the stake validator.
|
||||
, governorRedeemer :: Redeemer
|
||||
-- ^ The redeemer used to spend the governor.
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | See 'GovernorDatum.maximumProposalsPerStake'.
|
||||
-- | See 'GovernorDatum.maximumCreatedProposalsPerStake'.
|
||||
maxProposalPerStake :: Integer
|
||||
maxProposalPerStake = 3
|
||||
|
||||
|
|
@ -143,7 +161,7 @@ alteredStakeOwner = PubKeyCredential signer2
|
|||
|
||||
-- | Locks the stake that the input stake already has.
|
||||
defLocks :: [ProposalLock]
|
||||
defLocks = [Created (ProposalId 0)]
|
||||
defLocks = [ProposalLock (ProposalId 0) Created]
|
||||
|
||||
-- | The effect of the newly created proposal.
|
||||
defEffects :: StrictMap.Map ResultTag ProposalEffectGroup
|
||||
|
|
@ -164,7 +182,7 @@ governorInputDatum =
|
|||
, nextProposalId = thisProposalId
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = maxProposalPerStake
|
||||
, maximumCreatedProposalsPerStake = maxProposalPerStake
|
||||
}
|
||||
|
||||
-- | Create governor output datum given the parameters.
|
||||
|
|
@ -179,7 +197,7 @@ mkGovernorOutputDatum ps =
|
|||
, nextProposalId = nextPid
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = maxProposalPerStake
|
||||
, maximumCreatedProposalsPerStake = maxProposalPerStake
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -190,7 +208,7 @@ mkStakeInputDatum ps =
|
|||
let locks =
|
||||
if ps.createdMoreThanMaximumProposals
|
||||
then
|
||||
Created . ProposalId
|
||||
flip ProposalLock Created . ProposalId
|
||||
<$> take
|
||||
(fromInteger maxProposalPerStake)
|
||||
[1 ..]
|
||||
|
|
@ -209,10 +227,10 @@ mkStakeOutputDatum ps =
|
|||
newLocks =
|
||||
if ps.invalidNewLocks
|
||||
then
|
||||
[ Voted thisProposalId (ResultTag 0)
|
||||
, Voted thisProposalId (ResultTag 1)
|
||||
[ ProposalLock thisProposalId $ Voted (ResultTag 0) 100
|
||||
, ProposalLock thisProposalId $ Voted (ResultTag 1) 100
|
||||
]
|
||||
else [Created thisProposalId]
|
||||
else [ProposalLock thisProposalId Created]
|
||||
locks = newLocks <> inputDatum.lockedBy
|
||||
newOwner = mkOwner ps
|
||||
in inputDatum
|
||||
|
|
@ -289,6 +307,30 @@ createProposal ps = builder
|
|||
|
||||
---
|
||||
|
||||
attacker = head validatorHashes
|
||||
|
||||
fakeStakeBuilder =
|
||||
if ps.fakeSST
|
||||
then
|
||||
mconcat
|
||||
[ input @b $
|
||||
mconcat
|
||||
[ script attacker
|
||||
, withValue $
|
||||
Value.singleton
|
||||
stakeSymbol
|
||||
(validatorHashToTokenName attacker)
|
||||
1
|
||||
, withDatum $
|
||||
(mkStakeInputDatum ps)
|
||||
{ stakedAmount = 10000000000
|
||||
}
|
||||
]
|
||||
]
|
||||
else mempty
|
||||
|
||||
---
|
||||
|
||||
governorValue = sortValue $ gst <> minAda
|
||||
stakeValue =
|
||||
sortValue $
|
||||
|
|
@ -324,7 +366,7 @@ createProposal ps = builder
|
|||
[ script governorValidatorHash
|
||||
, withValue governorValue
|
||||
, withDatum governorInputDatum
|
||||
, withRedeemer governorRedeemer
|
||||
, withRedeemer ps.governorRedeemer
|
||||
, withRef governorRef
|
||||
]
|
||||
, output $
|
||||
|
|
@ -334,19 +376,39 @@ createProposal ps = builder
|
|||
, withDatum (mkGovernorOutputDatum ps)
|
||||
]
|
||||
, ---
|
||||
input $
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeInputDatum ps)
|
||||
, withRef stakeRef
|
||||
]
|
||||
, output $
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeOutputDatum ps)
|
||||
]
|
||||
if ps.fakeSST
|
||||
then
|
||||
mconcat
|
||||
[ input @b $
|
||||
mconcat
|
||||
[ script attacker
|
||||
, withValue $
|
||||
Value.singleton
|
||||
stakeSymbol
|
||||
(validatorHashToTokenName attacker)
|
||||
1
|
||||
, withDatum $
|
||||
(mkStakeInputDatum ps)
|
||||
{ stakedAmount = 10000000000
|
||||
}
|
||||
]
|
||||
]
|
||||
else
|
||||
mconcat
|
||||
[ input $
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeInputDatum ps)
|
||||
, withRef stakeRef
|
||||
]
|
||||
, output $
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeOutputDatum ps)
|
||||
]
|
||||
]
|
||||
, ---
|
||||
output $
|
||||
mconcat
|
||||
|
|
@ -354,6 +416,8 @@ createProposal ps = builder
|
|||
, withValue proposalValue
|
||||
, withDatum (mkProposalOutputDatum ps)
|
||||
]
|
||||
, ---
|
||||
fakeStakeBuilder
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -362,10 +426,6 @@ createProposal ps = builder
|
|||
stakeRedeemer :: StakeRedeemer
|
||||
stakeRedeemer = PermitVote
|
||||
|
||||
-- | Spend the governor with the 'CreateProposal' redeemer.
|
||||
governorRedeemer :: GovernorRedeemer
|
||||
governorRedeemer = CreateProposal
|
||||
|
||||
-- | Mint the PST with an arbitrary redeemer. Doesn't really matter.
|
||||
proposalPolicyRedeemer :: ()
|
||||
proposalPolicyRedeemer = ()
|
||||
|
|
@ -383,6 +443,8 @@ totallyValidParameters =
|
|||
, timeRangeTightEnough = True
|
||||
, timeRangeClosed = True
|
||||
, proposalStatus = Draft
|
||||
, fakeSST = False
|
||||
, governorRedeemer = Redeemer $ toBuiltinData CreateProposal
|
||||
}
|
||||
|
||||
invalidOutputGovernorDatumParameters :: Parameters
|
||||
|
|
@ -435,6 +497,24 @@ invalidProposalStatusParameters =
|
|||
)
|
||||
[VotingReady, Locked, Finished]
|
||||
|
||||
fakeSSTParameters :: Parameters
|
||||
fakeSSTParameters =
|
||||
totallyValidParameters
|
||||
{ fakeSST = True
|
||||
}
|
||||
|
||||
wrongGovernorRedeemer :: Parameters
|
||||
wrongGovernorRedeemer =
|
||||
totallyValidParameters
|
||||
{ governorRedeemer = Redeemer $ toBuiltinData MintGATs
|
||||
}
|
||||
|
||||
wrongGovernorRedeemer1 :: Parameters
|
||||
wrongGovernorRedeemer1 =
|
||||
totallyValidParameters
|
||||
{ governorRedeemer = Redeemer $ toBuiltinData MutateGovernor
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Create a test tree that runs the proposal minting policy, the governor
|
||||
|
|
@ -467,7 +547,7 @@ mkTestTree
|
|||
"governor"
|
||||
governorValidator
|
||||
governorInputDatum
|
||||
governorRedeemer
|
||||
ps.governorRedeemer
|
||||
(spend governorRef)
|
||||
|
||||
stakeTest =
|
||||
|
|
|
|||
|
|
@ -20,9 +20,10 @@ import Agora.Proposal.Time (
|
|||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
ProposalLock (
|
||||
ProposalAction (
|
||||
Voted
|
||||
),
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote, RetractVotes),
|
||||
)
|
||||
|
|
@ -128,8 +129,19 @@ mkStakeInputOutputDatums op =
|
|||
|
||||
allStakes = take 10 $ firstStake : otherStakes
|
||||
|
||||
createdAt = (def :: ProposalTimingConfig).votingTime - 1
|
||||
|
||||
stakeWithLock =
|
||||
(\stake -> stake {lockedBy = [Voted defProposalId defResultTag]})
|
||||
( \stake ->
|
||||
stake
|
||||
{ lockedBy =
|
||||
[ ProposalLock defProposalId $
|
||||
Voted
|
||||
defResultTag
|
||||
createdAt
|
||||
]
|
||||
}
|
||||
)
|
||||
<$> allStakes
|
||||
in wrap op (,) allStakes stakeWithLock
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ module Sample.Proposal.Unlock (
|
|||
SignedBy (..),
|
||||
TransactionParameters (..),
|
||||
ProposalParameters (..),
|
||||
SSTOwner (..),
|
||||
StakeParameters (..),
|
||||
Validity (..),
|
||||
unlock,
|
||||
|
|
@ -26,6 +27,8 @@ module Sample.Proposal.Unlock (
|
|||
mkRemoveCreatorLockBeforeFinished,
|
||||
mkCreatorRetractVotes,
|
||||
mkChangeOutputStakeValue,
|
||||
mkUseFakeStakes,
|
||||
mkDisrespectCooldown,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -40,13 +43,18 @@ import Agora.Proposal (
|
|||
ProposalVotes (..),
|
||||
ResultTag (..),
|
||||
)
|
||||
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..))
|
||||
import Agora.Proposal.Time (
|
||||
ProposalStartingTime (ProposalStartingTime),
|
||||
ProposalTimingConfig (..),
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
ProposalAction (Created, Voted),
|
||||
ProposalLock (..),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (RetractVotes),
|
||||
)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Map.Strict qualified as StrictMap
|
||||
import Data.Tagged (Tagged, untag)
|
||||
|
|
@ -64,8 +72,11 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
POSIXTime,
|
||||
PubKeyHash,
|
||||
TxOutRef (..),
|
||||
)
|
||||
|
|
@ -76,7 +87,7 @@ import Sample.Shared (
|
|||
proposalAssetClass,
|
||||
proposalValidator,
|
||||
proposalValidatorHash,
|
||||
stakeAssetClass,
|
||||
stakeSymbol,
|
||||
stakeValidator,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
|
|
@ -138,7 +149,7 @@ data ParameterBundle = ParameterBundle
|
|||
|
||||
data SignedBy = Owner | Delegatee | Unknown
|
||||
|
||||
data TimeRange = WhileVoting | AfterVoting
|
||||
data TimeRange = WhileVoting {offset :: POSIXTime} | AfterVoting
|
||||
|
||||
data TransactionParameters = TransactionParameters
|
||||
{ signedBy :: SignedBy
|
||||
|
|
@ -162,12 +173,18 @@ data StakeRole
|
|||
Irrelevant
|
||||
deriving stock (Bounded, Enum, Show)
|
||||
|
||||
data SSTOwner
|
||||
= StakeValidator
|
||||
| Attacker
|
||||
|
||||
data StakeParameters = StakeParameters
|
||||
{ numStakes :: Integer
|
||||
, stakeRole :: StakeRole
|
||||
, removeVoterLock :: Bool
|
||||
, removeCreatorLock :: Bool
|
||||
, alterOutputValue :: Bool
|
||||
, sstOwner :: SSTOwner
|
||||
, votingLockCreatedAt :: POSIXTime
|
||||
}
|
||||
|
||||
data Validity = Validity
|
||||
|
|
@ -194,14 +211,20 @@ mkStakeInputDatum ps =
|
|||
where
|
||||
stakeLocks = mkStakeLocks' ps.stakeRole
|
||||
|
||||
mkStakeLocks' Voter = [Voted defProposalId defVoteFor]
|
||||
mkStakeLocks' Creator = [Created defProposalId]
|
||||
mkStakeLocks' Voter =
|
||||
[ ProposalLock defProposalId $
|
||||
Voted defVoteFor ps.votingLockCreatedAt
|
||||
]
|
||||
mkStakeLocks' Creator = [ProposalLock defProposalId Created]
|
||||
mkStakeLocks' Both = mkStakeLocks' Voter <> mkStakeLocks' Creator
|
||||
mkStakeLocks' Irrelevant =
|
||||
let ProposalId pid = defProposalId
|
||||
ResultTag vid = defVoteFor
|
||||
in [ Voted (ProposalId $ pid + 1) (ResultTag $ vid + 1)
|
||||
, Created (ProposalId $ pid + 1)
|
||||
in [ ProposalLock (ProposalId $ pid + 1) $
|
||||
Voted
|
||||
(ResultTag $ vid + 1)
|
||||
ps.votingLockCreatedAt
|
||||
, ProposalLock (ProposalId $ pid + 1) Created
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -275,18 +298,21 @@ unlock ps = builder
|
|||
|
||||
---
|
||||
|
||||
sst = assetClassValue stakeAssetClass 1
|
||||
sstName = case ps.stakeParameters.sstOwner of
|
||||
StakeValidator -> validatorHashToTokenName stakeValidatorHash
|
||||
_ -> ""
|
||||
|
||||
sst = Value.singleton stakeSymbol sstName 1
|
||||
|
||||
stakeInputDatum = mkStakeInputDatum ps.stakeParameters
|
||||
|
||||
-- TODO respect timing
|
||||
removeLocks v c =
|
||||
filter $
|
||||
not
|
||||
. ( \case
|
||||
Created pid -> c && pid == defProposalId
|
||||
Cosigned pid -> c && pid == defProposalId
|
||||
Voted pid _ -> v && pid == defProposalId
|
||||
)
|
||||
filter $ \(ProposalLock pid action) ->
|
||||
pid == defProposalId
|
||||
&& case action of
|
||||
Voted _ _ -> v
|
||||
_ -> c
|
||||
|
||||
stakeOutputDatum =
|
||||
stakeInputDatum
|
||||
|
|
@ -342,9 +368,14 @@ unlock ps = builder
|
|||
ProposalStartingTime s = defStartingTime
|
||||
|
||||
time = case ps.transactionParameters.timeRange of
|
||||
WhileVoting ->
|
||||
let lb = s + (def :: ProposalTimingConfig).draftTime
|
||||
ub = lb + (def :: ProposalTimingConfig).votingTime
|
||||
WhileVoting offset ->
|
||||
let lb =
|
||||
ps.stakeParameters.votingLockCreatedAt
|
||||
+ offset
|
||||
ub =
|
||||
s
|
||||
+ (def :: ProposalTimingConfig).draftTime
|
||||
+ (def :: ProposalTimingConfig).votingTime
|
||||
in closedBoundedInterval (lb + 1) (ub - 1)
|
||||
AfterVoting ->
|
||||
let lb =
|
||||
|
|
@ -415,12 +446,22 @@ mkValidVoterRetractVotes i =
|
|||
, removeVoterLock = True
|
||||
, removeCreatorLock = False
|
||||
, alterOutputValue = False
|
||||
, sstOwner = StakeValidator
|
||||
, votingLockCreatedAt =
|
||||
coerce defStartingTime
|
||||
+ (def :: ProposalTimingConfig).draftTime
|
||||
+ 1
|
||||
}
|
||||
, transactionParameters =
|
||||
TransactionParameters
|
||||
{ signedBy = Owner
|
||||
, timeRange =
|
||||
WhileVoting
|
||||
{ offset =
|
||||
coerce
|
||||
(def :: ProposalTimingConfig).minStakeVotingTime
|
||||
+ 5
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -530,10 +571,6 @@ mkCreatorRetractVotes i =
|
|||
template.stakeParameters
|
||||
{ stakeRole = Creator
|
||||
}
|
||||
, transactionParameters =
|
||||
template.transactionParameters
|
||||
{ timeRange = WhileVoting
|
||||
}
|
||||
}
|
||||
|
||||
mkChangeOutputStakeValue :: Integer -> ParameterBundle
|
||||
|
|
@ -545,3 +582,29 @@ mkChangeOutputStakeValue i =
|
|||
{ alterOutputValue = True
|
||||
}
|
||||
}
|
||||
|
||||
mkUseFakeStakes :: Integer -> ParameterBundle
|
||||
mkUseFakeStakes i =
|
||||
let template = mkValidVoterCreatorRetractVotes i
|
||||
in template
|
||||
{ stakeParameters =
|
||||
template.stakeParameters
|
||||
{ sstOwner = Attacker
|
||||
}
|
||||
}
|
||||
|
||||
mkDisrespectCooldown :: Integer -> ParameterBundle
|
||||
mkDisrespectCooldown i =
|
||||
let template = mkValidVoterCreatorRetractVotes i
|
||||
in template
|
||||
{ transactionParameters =
|
||||
template.transactionParameters
|
||||
{ timeRange =
|
||||
WhileVoting
|
||||
{ offset =
|
||||
coerce
|
||||
(def :: ProposalTimingConfig).minStakeVotingTime
|
||||
- 5
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ module Sample.Proposal.Vote (
|
|||
mkTestTree,
|
||||
mkValidOwnerVoteBundle,
|
||||
mkValidDelegateeVoteBundle,
|
||||
delegateeVoteWithOwnAndDelegatedStakeBundle,
|
||||
transparentAssets,
|
||||
transactionNotAuthorized,
|
||||
voteForNonexistentOutcome,
|
||||
|
|
@ -35,6 +36,7 @@ import Agora.Proposal (
|
|||
ProposalId (ProposalId),
|
||||
ProposalRedeemer (Vote),
|
||||
ProposalStatus (VotingReady),
|
||||
ProposalThresholds (vote),
|
||||
ProposalVotes (ProposalVotes),
|
||||
ResultTag (ResultTag),
|
||||
)
|
||||
|
|
@ -44,7 +46,8 @@ import Agora.Proposal.Time (
|
|||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (
|
||||
ProposalLock (Voted),
|
||||
ProposalAction (Voted),
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (Destroy, PermitVote),
|
||||
)
|
||||
|
|
@ -66,7 +69,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (adaClass, assetClassValue)
|
||||
import PlutusLedgerApi.V2 (Credential (PubKeyCredential), PubKeyHash)
|
||||
import PlutusLedgerApi.V2 (Credential (PubKeyCredential), Interval, POSIXTime, PubKeyHash)
|
||||
import PlutusLedgerApi.V2.Contexts (TxOutRef (TxOutRef))
|
||||
import Sample.Proposal.Shared (proposalTxRef)
|
||||
import Sample.Shared (
|
||||
|
|
@ -98,6 +101,7 @@ newtype VoteParameters = VoteParameters {voteFor :: ResultTag}
|
|||
|
||||
data StakeParameters = StakeParameters
|
||||
{ numStakes :: Integer
|
||||
, mixInDelegateeAsOwner :: Bool
|
||||
, stakeInputParameters :: StakeInputParameters
|
||||
, stakeOutputParameters :: StakeOutputParameters
|
||||
}
|
||||
|
|
@ -142,6 +146,24 @@ delegatee = pubKeyHashes !! 1
|
|||
unknownSig :: PubKeyHash
|
||||
unknownSig = pubKeyHashes !! 2
|
||||
|
||||
validTimeRangeLowerBound :: POSIXTime
|
||||
validTimeRangeLowerBound =
|
||||
0
|
||||
+ (def :: ProposalTimingConfig).draftTime
|
||||
+ 1
|
||||
|
||||
validTimeRangeUpperBound :: POSIXTime
|
||||
validTimeRangeUpperBound =
|
||||
validTimeRangeLowerBound
|
||||
+ (def :: ProposalTimingConfig).votingTime
|
||||
- 2
|
||||
|
||||
validTimeRange :: Interval POSIXTime
|
||||
validTimeRange =
|
||||
closedBoundedInterval
|
||||
validTimeRangeLowerBound
|
||||
validTimeRangeUpperBound
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
initialVotes :: StrictMap.Map ResultTag Integer
|
||||
|
|
@ -194,8 +216,8 @@ mkStakeInputDatum params =
|
|||
, owner = PubKeyCredential stakeOwner
|
||||
, delegatedTo = Just (PubKeyCredential delegatee)
|
||||
, lockedBy =
|
||||
[ Voted (ProposalId 0) (ResultTag 0)
|
||||
, Voted (ProposalId 1) (ResultTag 2)
|
||||
[ ProposalLock (ProposalId 0) $ Voted (ResultTag 0) 100
|
||||
, ProposalLock (ProposalId 1) $ Voted (ResultTag 2) 200
|
||||
]
|
||||
}
|
||||
|
||||
|
|
@ -224,9 +246,11 @@ vote params =
|
|||
<> minAda
|
||||
|
||||
newLock =
|
||||
Voted
|
||||
ProposalLock
|
||||
proposalInputDatum.proposalId
|
||||
params.voteParameters.voteFor
|
||||
$ Voted
|
||||
params.voteParameters.voteFor
|
||||
validTimeRangeUpperBound
|
||||
|
||||
updatedLocks =
|
||||
if params.stakeParameters.stakeOutputParameters.dontAddNewLock
|
||||
|
|
@ -256,6 +280,16 @@ vote params =
|
|||
stakeRedeemer =
|
||||
mkStakeRedeemer params.stakeParameters.stakeOutputParameters
|
||||
|
||||
mixOwner i datum =
|
||||
if params.stakeParameters.mixInDelegateeAsOwner
|
||||
&& i == 2
|
||||
then
|
||||
datum
|
||||
{ owner = PubKeyCredential delegatee
|
||||
, delegatedTo = Nothing
|
||||
}
|
||||
else datum
|
||||
|
||||
stakeBuilder :: b
|
||||
stakeBuilder =
|
||||
foldMap
|
||||
|
|
@ -265,7 +299,7 @@ vote params =
|
|||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeInputValue
|
||||
, withInlineDatum stakeInputDatum
|
||||
, withInlineDatum $ mixOwner i stakeInputDatum
|
||||
, withRedeemer stakeRedeemer
|
||||
, withRef $ mkStakeRef numProposals' i
|
||||
]
|
||||
|
|
@ -276,7 +310,7 @@ vote params =
|
|||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeOutputValue
|
||||
, withInlineDatum stakeOutputDatum
|
||||
, withInlineDatum $ mixOwner i stakeOutputDatum
|
||||
]
|
||||
]
|
||||
)
|
||||
|
|
@ -344,13 +378,6 @@ vote params =
|
|||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
validTimeRange =
|
||||
closedBoundedInterval
|
||||
((def :: ProposalTimingConfig).draftTime + 1)
|
||||
((def :: ProposalTimingConfig).votingTime - 1)
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
miscBuilder :: b
|
||||
miscBuilder =
|
||||
mconcat
|
||||
|
|
@ -419,9 +446,10 @@ mkValidOwnerVoteBundle stakes =
|
|||
, stakeParameters =
|
||||
StakeParameters
|
||||
{ numStakes = stakes
|
||||
, mixInDelegateeAsOwner = False
|
||||
, stakeInputParameters =
|
||||
StakeInputParameters
|
||||
{ perStakeGTs = 114514
|
||||
{ perStakeGTs = (def :: ProposalThresholds).vote
|
||||
}
|
||||
, stakeOutputParameters =
|
||||
StakeOutputParameters
|
||||
|
|
@ -452,6 +480,16 @@ mkValidDelegateeVoteBundle stakes =
|
|||
}
|
||||
}
|
||||
|
||||
delegateeVoteWithOwnAndDelegatedStakeBundle :: ParameterBundle
|
||||
delegateeVoteWithOwnAndDelegatedStakeBundle =
|
||||
let template = mkValidDelegateeVoteBundle 5
|
||||
in template
|
||||
{ stakeParameters =
|
||||
template.stakeParameters
|
||||
{ mixInDelegateeAsOwner = True
|
||||
}
|
||||
}
|
||||
|
||||
ownerVoteWithSignleStake :: ParameterBundle
|
||||
ownerVoteWithSignleStake = mkValidOwnerVoteBundle 1
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ module Sample.Shared (
|
|||
signer,
|
||||
signer2,
|
||||
minAda,
|
||||
deterministicTracingConfing,
|
||||
deterministicTracingConfig,
|
||||
mkRedeemer,
|
||||
|
||||
-- * Agora Scripts
|
||||
|
|
@ -72,9 +72,6 @@ import Agora.Proposal.Time (
|
|||
ProposalTimingConfig (..),
|
||||
)
|
||||
import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
|
||||
import Agora.Utils (
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Data.Default.Class (Default (..))
|
||||
import Data.Map (Map, (!))
|
||||
import Data.Tagged (Tagged (..))
|
||||
|
|
@ -86,6 +83,7 @@ import Plutarch.Api.V2 (
|
|||
validatorHash,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Address (scriptHashAddress)
|
||||
import PlutusLedgerApi.V1.Value (TokenName, Value)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (
|
||||
|
|
@ -123,8 +121,8 @@ import ScriptExport.ScriptInfo (runLinker)
|
|||
-- Plutarch compiler configauration.
|
||||
-- TODO: add the ability to change this value. Maybe wrap everything in a
|
||||
-- Reader monad?
|
||||
deterministicTracingConfing :: Config
|
||||
deterministicTracingConfing = Config DetTracing
|
||||
deterministicTracingConfig :: Config
|
||||
deterministicTracingConfig = Config DetTracing
|
||||
|
||||
governor :: Governor
|
||||
governor = Governor oref gt mc
|
||||
|
|
@ -144,7 +142,7 @@ agoraScripts =
|
|||
(fmap (view #script) . view #scripts)
|
||||
( runLinker
|
||||
linker
|
||||
(Bootstrap.agoraScripts deterministicTracingConfing)
|
||||
(Bootstrap.agoraScripts deterministicTracingConfig)
|
||||
governor
|
||||
)
|
||||
|
||||
|
|
@ -242,6 +240,8 @@ instance Default ProposalTimingConfig where
|
|||
, votingTime = 1000
|
||||
, lockingTime = 2000
|
||||
, executingTime = 3000
|
||||
, minStakeVotingTime = 100
|
||||
, votingTimeRangeMaxWidth = 1000000
|
||||
}
|
||||
|
||||
{- | Default value of 'Agora.Governor.GovernorDatum.createProposalTimeRangeMaxWidth'.
|
||||
|
|
|
|||
|
|
@ -20,8 +20,7 @@ module Sample.Stake.Create (
|
|||
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 Agora.Stake (ProposalAction (Created), ProposalLock (ProposalLock), StakeDatum (..))
|
||||
import Data.Semigroup (stimesMonoid)
|
||||
import Data.Tagged (Tagged)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -36,6 +35,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
|
|
@ -255,6 +255,6 @@ alreadyHasLocks =
|
|||
{ stakedAmount = 114514
|
||||
, owner = PubKeyCredential signer
|
||||
, delegatedTo = Nothing
|
||||
, lockedBy = [Created $ ProposalId 0]
|
||||
, lockedBy = [ProposalLock (ProposalId 0) Created]
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ module Sample.Stake.Destroy (
|
|||
|
||||
import Agora.Proposal (ProposalId (..))
|
||||
import Agora.Stake (
|
||||
ProposalLock (Created),
|
||||
ProposalAction (Created),
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (Destroy),
|
||||
)
|
||||
|
|
@ -105,7 +106,7 @@ mkStakeInputDatum ps =
|
|||
{ stakedAmount = 114514
|
||||
, owner = PubKeyCredential owner
|
||||
, delegatedTo = Just $ PubKeyCredential delegatee
|
||||
, lockedBy = [Created $ ProposalId 0 | ps.notUnlocked]
|
||||
, lockedBy = [ProposalLock (ProposalId 0) Created | ps.notUnlocked]
|
||||
}
|
||||
|
||||
mkStakeRef :: Int -> TxOutRef
|
||||
|
|
|
|||
74
agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs
Normal file
74
agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
module Sample.Stake.UnauthorizedMintingExploit (
|
||||
Parameters (..),
|
||||
exploit,
|
||||
mkTestCase,
|
||||
) where
|
||||
|
||||
import Plutarch.Context (
|
||||
input,
|
||||
mint,
|
||||
normalizeValue,
|
||||
output,
|
||||
script,
|
||||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (
|
||||
minAda,
|
||||
stakeAssetClass,
|
||||
stakePolicy,
|
||||
stakeSymbol,
|
||||
stakeValidatorHash,
|
||||
)
|
||||
import Test.Specification (SpecificationTree, testPolicy)
|
||||
import Test.Util (
|
||||
CombinableBuilder,
|
||||
mkMinting,
|
||||
validatorHashes,
|
||||
)
|
||||
|
||||
newtype Parameters = Parameters
|
||||
{ inputSST :: Int
|
||||
}
|
||||
|
||||
exploit ::
|
||||
forall b.
|
||||
CombinableBuilder b =>
|
||||
Parameters ->
|
||||
b
|
||||
exploit (Parameters inputSST) =
|
||||
mconcat
|
||||
[ input $
|
||||
mconcat
|
||||
[ script attacker
|
||||
, withValue $
|
||||
normalizeValue $
|
||||
minAda <> fakeSSTValue inputSST
|
||||
]
|
||||
, mint $ fakeSSTValue $ negate inputSST
|
||||
, mint sst
|
||||
, output $
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue $
|
||||
normalizeValue $
|
||||
minAda <> sst
|
||||
]
|
||||
]
|
||||
where
|
||||
attacker = head validatorHashes
|
||||
|
||||
fakeSSTValue =
|
||||
Value.singleton
|
||||
stakeSymbol
|
||||
(validatorHashToTokenName attacker)
|
||||
. fromIntegral
|
||||
|
||||
sst = assetClassValue stakeAssetClass 1
|
||||
|
||||
mkTestCase :: String -> Parameters -> SpecificationTree
|
||||
mkTestCase name ps =
|
||||
testPolicy False name stakePolicy () $
|
||||
mkMinting exploit ps stakeSymbol
|
||||
|
|
@ -10,7 +10,7 @@ Tests for Authority token functions
|
|||
module Spec.AuthorityToken (specs) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Plutarch (ClosedTerm, POpaque, perror, popaque)
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Plutarch.Extra.Compile (mustCompile)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V1 (
|
||||
|
|
@ -29,21 +29,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
|
|||
singleton,
|
||||
)
|
||||
import PlutusTx.AssocMap qualified as AssocMap (empty)
|
||||
import Sample.AuthorityToken.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
scriptFails,
|
||||
scriptSucceeds,
|
||||
)
|
||||
import Prelude (
|
||||
Maybe (Nothing),
|
||||
PBool,
|
||||
Semigroup ((<>)),
|
||||
fmap,
|
||||
pconstant,
|
||||
pif,
|
||||
($),
|
||||
)
|
||||
|
||||
currencySymbol :: CurrencySymbol
|
||||
currencySymbol = "deadbeef"
|
||||
|
|
@ -54,7 +46,7 @@ mkInputs = fmap (TxInInfo (TxOutRef "" 0))
|
|||
singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
|
||||
singleAuthorityTokenBurnedTest mint outs =
|
||||
let actual :: ClosedTerm PBool
|
||||
actual = singleAuthorityTokenBurned (pconstant currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
|
||||
actual = singleAuthorityTokenBurned (pconstant $ Tagged currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
|
||||
s :: ClosedTerm POpaque
|
||||
s =
|
||||
pif
|
||||
|
|
@ -150,4 +142,15 @@ specs =
|
|||
]
|
||||
)
|
||||
]
|
||||
, group "unauthorized minting exploit"
|
||||
$ map
|
||||
( UnauthorizedMintingExploit.mkTestCase "(negative test)"
|
||||
. uncurry UnauthorizedMintingExploit.Parameters
|
||||
)
|
||||
$ let l = [1 .. 10]
|
||||
in [ (burnt, minted)
|
||||
| burnt <- l
|
||||
, minted <- l
|
||||
, minted < burnt
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -85,6 +85,24 @@ specs =
|
|||
True
|
||||
)
|
||||
Create.invalidProposalStatusParameters
|
||||
, Create.mkTestTree
|
||||
"fake SST"
|
||||
Create.fakeSSTParameters
|
||||
True
|
||||
False
|
||||
False
|
||||
, Create.mkTestTree
|
||||
"wrong governor redeemer"
|
||||
Create.wrongGovernorRedeemer
|
||||
False
|
||||
False
|
||||
True
|
||||
, Create.mkTestTree
|
||||
"wrong governor redeemer"
|
||||
Create.wrongGovernorRedeemer1
|
||||
False
|
||||
False
|
||||
True
|
||||
]
|
||||
]
|
||||
, group
|
||||
|
|
@ -148,6 +166,10 @@ specs =
|
|||
"transparent non-GT tokens"
|
||||
Vote.transparentAssets
|
||||
(Vote.Validity True True)
|
||||
, Vote.mkTestTree
|
||||
"Delegatee vote with own and delegated stakes in one tx"
|
||||
Vote.delegateeVoteWithOwnAndDelegatedStakeBundle
|
||||
(Vote.Validity True True)
|
||||
]
|
||||
, group
|
||||
"illegal"
|
||||
|
|
@ -327,6 +349,25 @@ specs =
|
|||
, forGovernorValidator = Just False
|
||||
, forAuthorityTokenPolicy = Just True
|
||||
}
|
||||
, Advance.mkTestTree'
|
||||
"fastforward to finished"
|
||||
(\b -> unwords ["from", show b.proposalParameters.fromStatus])
|
||||
(Advance.mkFastforwardToFinishBundles cs es)
|
||||
Advance.Validity
|
||||
{ forProposalValidator = False
|
||||
, forStakeValidator = True
|
||||
, forGovernorValidator = Just False
|
||||
, forAuthorityTokenPolicy = Just True
|
||||
}
|
||||
, Advance.mkTestTree
|
||||
"wrong governor redeemer"
|
||||
(Advance.mkBadGovernorRedeemerBundle cs es)
|
||||
Advance.Validity
|
||||
{ forProposalValidator = True
|
||||
, forStakeValidator = True
|
||||
, forGovernorValidator = Just False
|
||||
, forAuthorityTokenPolicy = Just False
|
||||
}
|
||||
]
|
||||
]
|
||||
, group "unlocking" $
|
||||
|
|
@ -392,6 +433,14 @@ specs =
|
|||
"change output stake value"
|
||||
(Unlock.mkChangeOutputStakeValue nStakes)
|
||||
(Unlock.Validity True False)
|
||||
, Unlock.mkTestTree
|
||||
"use fake stake"
|
||||
(Unlock.mkUseFakeStakes nStakes)
|
||||
(Unlock.Validity False False)
|
||||
, Unlock.mkTestTree
|
||||
"retract votes in cooldown"
|
||||
(Unlock.mkDisrespectCooldown nStakes)
|
||||
(Unlock.Validity True False)
|
||||
]
|
||||
|
||||
legalGroup = group "legal" $ map mkLegalGroup stakeCountCases
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ import Sample.Stake qualified as Stake (
|
|||
import Sample.Stake.Create qualified as Create
|
||||
import Sample.Stake.Destroy qualified as Destroy
|
||||
import Sample.Stake.SetDelegate qualified as SetDelegate
|
||||
import Sample.Stake.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
|
||||
import Test.Specification (
|
||||
SpecificationTree,
|
||||
group,
|
||||
|
|
@ -179,5 +180,13 @@ specs =
|
|||
SetDelegate.invalidOutputStakeDatumParameters
|
||||
False
|
||||
]
|
||||
, group
|
||||
"unauthorized SST minting exploit"
|
||||
$ map
|
||||
( UnauthorizedMintingExploit.mkTestCase
|
||||
"(negative test)"
|
||||
. UnauthorizedMintingExploit.Parameters
|
||||
)
|
||||
[1 .. 20]
|
||||
]
|
||||
]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue