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

Merge pull request #168 from Liqwid-Labs/connor/witness-ref-stake

Browse source 
Witness stakes with reference input
This commit is contained in:
方泓睿 2022-09-13 21:08:54 +08:00 • committed by GitHub
commit de4e2ec7eb
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
22 changed files with 1444 additions and 2454 deletions
Download patch file Download diff file Expand all files Collapse all files

4
CHANGELOG.md
View file

@ -6,6 +6,10 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
### Modified
- Witness stakes with reference input. Stake redeemer `WitnessStake` is removed.
Included by [#168](https://github.com/Liqwid-Labs/agora/pull/168)
- `tracing` flag in `ScriptParams` of `agora-scripts` to enable/disable tracing in exported scripts.
NOTE: This changes the representation of `ScriptParams`. In order to preserve old behavior, the flag

10
agora-specs/Sample/Effect/GovernorMutation.hs
View file

@ -74,11 +74,17 @@ atAssetClass = assetClass authorityTokenSymbol tokenName
-- | The mock reference of the governor state UTXO.
govRef :: TxOutRef
govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
govRef =
TxOutRef
"d63fe09e6ac6e55dea82291149085d0a9b901df65087b83965188ee92fb25aef"
1
-- | The mock reference of the effect UTXO.
effectRef :: TxOutRef
effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
effectRef =
TxOutRef
"3ca6864670aae61a9f3e63064284cec00bd983d77cf4e1ab1e26bef34cafb0a9"
1
-- | The input effect datum in 'mkEffectTransaction'.
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum

89
agora-specs/Sample/Proposal/Advance.hs
View file

@ -29,7 +29,6 @@ module Sample.Proposal.Advance (
mkFromFinishedBundles,
mkInsufficientCosignsBundle,
mkToNextStateTooLateBundles,
mkInvalidOutputStakeBundles,
mkMintGATsForWrongEffectsBundle,
mkNoGATMintedBundle,
mkGATsWithWrongDatumBundle,
@ -46,6 +45,7 @@ import Agora.Governor (
import Agora.Proposal (
ProposalDatum (..),
ProposalEffectGroup,
ProposalEffectMetadata (ProposalEffectMetadata),
ProposalId (ProposalId),
ProposalRedeemer (AdvanceProposal),
ProposalStatus (..),
@ -66,7 +66,6 @@ import Agora.Proposal.Time (
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
StakeDatum (..),
StakeRedeemer (WitnessStake),
)
import Agora.Utils (scriptHashToTokenName)
import Control.Applicative (liftA2)
@ -75,15 +74,17 @@ import Data.Default (def)
import Data.List (singleton, sort)
import Data.Map.Strict qualified as StrictMap
import Data.Maybe (fromJust)
import Data.Tagged (Tagged (..), untag)
import Data.Tagged (untag)
import Plutarch.Context (
input,
mint,
output,
referenceInput,
script,
signedWith,
timeRange,
withDatum,
withInlineDatum,
withRef,
withValue,
)
@ -217,7 +218,6 @@ data StakeParameters = StakeParameters
{ numStake :: NumStake
, perStakeGTs :: Integer
, transactionSignedByOwners :: Bool
, invalidStakeOutputDatum :: Bool
}
-- | Represent the number of stakes or the number of the cosigners.
@ -355,7 +355,7 @@ mkStakeInputDatums :: StakeParameters -> [StakeDatum]
mkStakeInputDatums ps =
let template =
StakeDatum
{ stakedAmount = Tagged ps.perStakeGTs
{ stakedAmount = fromInteger ps.perStakeGTs
, owner = PubKeyCredential ""
, delegatedTo = Nothing
, lockedBy = []
@ -363,24 +363,6 @@ mkStakeInputDatums ps =
in (\owner -> template {owner = owner})
<$> mkStakeOwners ps.numStake
-- | Create the output stake datums given the parameters.
mkStakeOutputDatums :: StakeParameters -> [StakeDatum]
mkStakeOutputDatums ps =
let inputDatums = mkStakeInputDatums ps
outputStakedAmount =
Tagged $
if ps.invalidStakeOutputDatum
then ps.perStakeGTs * 10
else ps.perStakeGTs
modify inp = inp {stakedAmount = outputStakedAmount}
in modify <$> inputDatums
{- | Get the input stake datum given the index. The range of the index is
@[0, 'StakeParameters.numStake - 1']@
-}
getStakeInputDatumAt :: StakeParameters -> Index -> StakeDatum
getStakeInputDatumAt ps = (!!) (mkStakeInputDatums ps)
-- | Create the reference to a particular stake UTXO.
mkStakeRef :: Index -> TxOutRef
mkStakeRef = TxOutRef stakeTxRef . (+ 3) . fromIntegral
@ -397,39 +379,26 @@ mkStakeBuilder ps =
<> Value.assetClassValue
(untag governor.gtClassRef)
ps.perStakeGTs
perStake idx i o =
perStake idx i =
let withSig =
case (i.owner, ps.transactionSignedByOwners) of
(PubKeyCredential owner, True) -> signedWith owner
_ -> mempty
in mconcat
[ withSig
, input $
, referenceInput $
mconcat
[ script stakeValidatorHash
, withRef (mkStakeRef idx)
, withValue perStakeValue
, withDatum i
]
, output $
mconcat
[ script stakeValidatorHash
, withValue perStakeValue
, withDatum o
, withInlineDatum i
]
]
in mconcat $
zipWith3
zipWith
perStake
[0 :: Index ..]
(mkStakeInputDatums ps)
(mkStakeOutputDatums ps)
{- | The proposal redeemer used to spend the stake UTXO, which is always
'WitnessStake' in this case.
-}
stakeRedeemer :: StakeRedeemer
stakeRedeemer = WitnessStake
--------------------------------------------------------------------------------
@ -553,7 +522,7 @@ mkTestTree ::
Validity ->
SpecificationTree
mkTestTree name pb val =
group name $ mconcat [proposal, stake, governor, authority]
group name $ mconcat [proposal, governor, authority]
where
spend = mkSpending advance pb
@ -567,22 +536,6 @@ mkTestTree name pb val =
proposalInputDatum
proposalRedeemer
(spend proposalRef)
stake =
if pb.stakeParameters.numStake == 0
then mempty
else
let idx = 0
in singleton $
testValidator
val.forStakeValidator
"stake"
agoraScripts.compiledStakeValidator
(getStakeInputDatumAt pb.stakeParameters idx)
stakeRedeemer
( spend (mkStakeRef idx)
)
governor =
maybe [] singleton $
testValidator
@ -747,7 +700,7 @@ mkMockEffects useAuthScript n = effects
datums = repeat dummyDatumHash
effectMetadata = zip datums authScripts
effectMetadata = zipWith ProposalEffectMetadata datums authScripts
effectScripts = validatorHashes
effects =
@ -822,7 +775,6 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
compPerStakeGTsForDraft $
fromIntegral nCosigners
, transactionSignedByOwners = False
, invalidStakeOutputDatum = False
}
, governorParameters = Nothing
, authorityTokenParameters = []
@ -857,7 +809,7 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
let aut =
StrictMap.elems $
StrictMap.mapWithKey
( \vh (_, authScript) ->
( \vh (ProposalEffectMetadata _ authScript) ->
AuthorityTokenParameters
{ mintGATsFor = vh
, carryDatum = Just dummyDatum
@ -920,7 +872,6 @@ mkValidToFailedStateBundles nCosigners nEffects =
compPerStakeGTsForDraft $
fromIntegral nCosigners
, transactionSignedByOwners = False
, invalidStakeOutputDatum = False
}
, governorParameters = Nothing
, authorityTokenParameters = []
@ -965,22 +916,6 @@ mkToNextStateTooLateBundles nCosigners nEffects =
{ transactionTimeRange = mkTooLateTimeRange from
}
mkInvalidOutputStakeBundles :: Word -> Word -> [ParameterBundle]
mkInvalidOutputStakeBundles nCosigners nEffects =
liftA2
mkBundle
[True, False]
[Draft]
where
mkBundle authScript from =
let template = mkValidToNextStateBundle nCosigners nEffects authScript from
in template
{ stakeParameters =
template.stakeParameters
{ invalidStakeOutputDatum = True
}
}
mkUnexpectedOutputStakeBundles :: Word -> Word -> [ParameterBundle]
mkUnexpectedOutputStakeBundles nCosigners nEffects =
liftA2

85
agora-specs/Sample/Proposal/Cosign.hs
View file

@ -10,7 +10,6 @@ module Sample.Proposal.Cosign (
validCosignNParameters,
duplicateCosignersParameters,
statusNotDraftCosignNParameters,
invalidStakeOutputParameters,
mkTestTree,
) where
@ -31,25 +30,26 @@ import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
StakeDatum (StakeDatum, owner),
StakeRedeemer (WitnessStake),
stakedAmount,
)
import Data.Coerce (coerce)
import Data.Default (def)
import Data.List (sort)
import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged, untag)
import Data.Tagged (untag)
import Plutarch.Context (
input,
output,
referenceInput,
script,
signedWith,
timeRange,
txId,
withDatum,
withInlineDatum,
withRef,
withValue,
)
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 (
Credential (PubKeyCredential),
@ -61,6 +61,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared (
agoraScripts,
fromDiscrete,
governor,
minAda,
proposalPolicySymbol,
@ -71,7 +72,6 @@ import Sample.Shared (
)
import Test.Specification (
SpecificationTree,
group,
testValidator,
)
import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue)
@ -82,9 +82,6 @@ data Parameters = Parameters
-- ^ New cosigners to be added, and the owners of the generated stakes.
, proposalStatus :: ProposalStatus
-- ^ Current state of the proposal.
, alterOutputStakes :: Bool
-- ^ Whether to generate invalid stake outputs.
-- In particular, the 'stakedAmount' of all the stake datums will be set to zero.
}
-- | Owner of the creator stake, doesn't really matter in this case.
@ -92,7 +89,7 @@ proposalCreator :: PubKeyHash
proposalCreator = signer
-- | The amount of GTs every generated stake has, doesn't really matter in this case.
perStakedGTs :: Tagged GTTag Integer
perStakedGTs :: Discrete GTTag
perStakedGTs = 5
{- | Create input proposal datum given the parameters.
@ -151,34 +148,24 @@ cosign ps = builder
minAda
<> Value.assetClassValue
(untag governor.gtClassRef)
(untag perStakedGTs)
(fromDiscrete perStakedGTs)
<> sst
stakeBuilder =
foldMap
( \(stakeDatum, refIdx) ->
let stakeOutputDatum =
if ps.alterOutputStakes
then stakeDatum {stakedAmount = 0}
else stakeDatum
in mconcat
[ input $
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeDatum
, withRef (mkStakeRef refIdx)
]
, output $
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeOutputDatum
]
, case stakeDatum.owner of
PubKeyCredential k -> signedWith k
_ -> mempty
]
mconcat
[ referenceInput $
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withInlineDatum stakeDatum
, withRef (mkStakeRef refIdx)
]
, case stakeDatum.owner of
PubKeyCredential k -> signedWith k
_ -> mempty
]
)
$ zip
stakeInputDatums
@ -246,10 +233,6 @@ mkStakeRef idx =
mkProposalRedeemer :: Parameters -> ProposalRedeemer
mkProposalRedeemer = Cosign . sort . newCosigners
-- | Stake redeemer for cosuming all the stakes generated in the module.
stakeRedeemer :: StakeRedeemer
stakeRedeemer = WitnessStake
---
-- | Create a valid parameters that cosign the proposal with a given number of cosigners.
@ -259,7 +242,6 @@ validCosignNParameters n
Parameters
{ newCosigners = take n (fmap PubKeyCredential pubKeyHashes)
, proposalStatus = Draft
, alterOutputStakes = False
}
| otherwise = error "Number of cosigners should be positive"
@ -273,7 +255,6 @@ duplicateCosignersParameters =
Parameters
{ newCosigners = [PubKeyCredential proposalCreator]
, proposalStatus = Draft
, alterOutputStakes = False
}
---
@ -288,24 +269,12 @@ statusNotDraftCosignNParameters n =
Parameters
{ newCosigners = take n (fmap PubKeyCredential pubKeyHashes)
, proposalStatus = st
, alterOutputStakes = False
}
)
[VotingReady, Locked, Finished]
---
{- | Parameters thet change the output stake datums.
Invalid for both proposal validator and stake validator.
-}
invalidStakeOutputParameters :: Parameters
invalidStakeOutputParameters =
(validCosignNParameters 2)
{ alterOutputStakes = True
}
---
-- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run.
mkTestTree ::
-- | The name of the test group.
@ -314,7 +283,7 @@ mkTestTree ::
-- | Are the parameters valid for the proposal validator?
Bool ->
SpecificationTree
mkTestTree name ps isValid = group name [proposal, stake]
mkTestTree name ps isValid = proposal
where
spend = mkSpending cosign ps
@ -322,20 +291,8 @@ mkTestTree name ps isValid = group name [proposal, stake]
let proposalInputDatum = mkProposalInputDatum ps
in testValidator
isValid
"proposal"
(name <> ": proposal")
agoraScripts.compiledProposalValidator
proposalInputDatum
(mkProposalRedeemer ps)
(spend proposalRef)
stake =
let idx = 0
stakeInputDatum = mkStakeInputDatums ps !! idx
isValid = not ps.alterOutputStakes
in testValidator
isValid
"stake"
agoraScripts.compiledStakeValidator
stakeInputDatum
stakeRedeemer
(spend $ mkStakeRef idx)

9
agora-specs/Sample/Proposal/Create.hs
View file

@ -38,6 +38,7 @@ import Agora.Proposal.Time (
),
ProposalStartingTime (..),
)
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
ProposalLock (..),
@ -47,7 +48,7 @@ import Agora.Stake (
import Data.Coerce (coerce)
import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged, untag)
import Data.Tagged (untag)
import Plutarch.Context (
input,
mint,
@ -60,6 +61,7 @@ import Plutarch.Context (
withRef,
withValue,
)
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 (
Credential (PubKeyCredential),
@ -71,6 +73,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared (
agoraScripts,
fromDiscrete,
govAssetClass,
govValidatorHash,
governor,
@ -123,7 +126,7 @@ thisProposalId :: ProposalId
thisProposalId = ProposalId 25
-- | The arbitrary staked amount. Doesn;t really matter in this case.
stakedGTs :: Tagged _ Integer
stakedGTs :: Discrete GTTag
stakedGTs = 5
-- | The owner of the stake.
@ -289,7 +292,7 @@ createProposal ps = builder
sortValue $
sortValue $
sst
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakedGTs)
<> minAda
proposalValue = sortValue $ pst <> minAda

15
agora-specs/Sample/Proposal/UnlockStake.hs
View file

@ -36,6 +36,7 @@ import Agora.Proposal (
ResultTag (..),
)
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
ProposalLock (..),
@ -44,7 +45,7 @@ import Agora.Stake (
)
import Data.Default.Class (Default (def))
import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged (..), untag)
import Data.Tagged (untag)
import Plutarch.Context (
input,
output,
@ -52,9 +53,11 @@ import Plutarch.Context (
signedWith,
txId,
withDatum,
withRedeemer,
withRef,
withValue,
)
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 (
Credential (PubKeyCredential),
@ -64,6 +67,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared (
agoraScripts,
fromDiscrete,
governor,
minAda,
proposalPolicySymbol,
@ -99,13 +103,13 @@ defVoteFor :: ResultTag
defVoteFor = ResultTag 0
-- | The default number of GTs the stake will have.
defStakedGTs :: Tagged _ Integer
defStakedGTs :: Discrete GTTag
defStakedGTs = 100000
{- | If 'Parameters.alterOutputStake' is set to true, the
'StakeDatum.stakedAmount' will be set to this.
-}
alteredStakedGTs :: Tagged _ Integer
alteredStakedGTs :: Discrete GTTag
alteredStakedGTs = 100
-- | Default owner of the stakes.
@ -212,7 +216,7 @@ mkProposalDatumPair ::
ProposalId ->
(ProposalDatum, ProposalDatum)
mkProposalDatumPair params pid =
let inputVotes = mkInputVotes params.stakeRole $ untag defStakedGTs
let inputVotes = mkInputVotes params.stakeRole $ fromDiscrete defStakedGTs
input =
ProposalDatum
@ -266,6 +270,7 @@ unlockStake ps =
, withValue pst
, withDatum i
, withRef (mkProposalRef idx)
, withRedeemer proposalRedeemer
]
, output $
mconcat
@ -282,7 +287,7 @@ unlockStake ps =
mconcat
[ Value.assetClassValue
(untag governor.gtClassRef)
(untag defStakedGTs)
(fromDiscrete defStakedGTs)
, sst
, minAda
]

6
agora-specs/Sample/Proposal/Vote.hs
View file

@ -32,7 +32,7 @@ import Agora.Stake (
)
import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged (Tagged), untag)
import Data.Tagged (untag)
import Plutarch.Context (
input,
output,
@ -41,6 +41,7 @@ import Plutarch.Context (
timeRange,
txId,
withDatum,
withRedeemer,
withRef,
withValue,
)
@ -139,7 +140,7 @@ delegate = head pubKeyHashes
mkStakeInputDatum :: Parameters -> StakeDatum
mkStakeInputDatum params =
StakeDatum
{ stakedAmount = Tagged params.voteCount
{ stakedAmount = fromInteger params.voteCount
, owner = PubKeyCredential stakeOwner
, delegatedTo =
if params.voteAsDelegate
@ -230,6 +231,7 @@ vote params =
, withValue pst
, withDatum proposalInputDatum
, withRef proposalRef
, withRedeemer $ mkProposalRedeemer params
]
, input $
mconcat

6
agora-specs/Sample/Shared.hs
View file

@ -15,6 +15,7 @@ module Sample.Shared (
deterministicTracingConfing,
mkEffect,
mkRedeemer,
fromDiscrete,
-- * Agora Scripts
agoraScripts,
@ -73,6 +74,7 @@ import Agora.Utils (
CompiledValidator (getCompiledValidator),
validatorHashToTokenName,
)
import Data.Coerce (coerce)
import Data.Default.Class (Default (..))
import Data.Tagged (Tagged (..))
import Plutarch (Config (..), TracingMode (DetTracing))
@ -82,6 +84,7 @@ import Plutarch.Api.V2 (
mkValidator,
validatorHash,
)
import Plutarch.SafeMoney (Discrete (Discrete))
import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Contexts (TxOut (..))
import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..))
@ -225,6 +228,9 @@ mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer
mkRedeemer = Redeemer . toBuiltinData
fromDiscrete :: forall tag. Discrete tag -> Integer
fromDiscrete = coerce
------------------------------------------------------------------
treasuryOut :: TxOut

12
agora-specs/Sample/Stake.hs
View file

@ -23,7 +23,7 @@ import Agora.SafeMoney (GTTag)
import Agora.Stake (
StakeDatum (StakeDatum, stakedAmount),
)
import Data.Tagged (Tagged, untag)
import Data.Tagged (untag)
import Plutarch.Context (
MintingBuilder,
SpendingBuilder,
@ -41,6 +41,7 @@ import Plutarch.Context (
withSpendingOutRef,
withValue,
)
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
import PlutusLedgerApi.V1.Value qualified as Value (
assetClassValue,
@ -56,6 +57,7 @@ import PlutusLedgerApi.V2 (
)
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Shared (
fromDiscrete,
governor,
signer,
stakeAssetClass,
@ -112,9 +114,9 @@ stakeCreationUnsigned =
-- | Config for creating a ScriptContext that deposits or withdraws.
data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Tagged GTTag Integer
{ startAmount :: Discrete GTTag
-- ^ The amount of GT stored before the transaction.
, delta :: Tagged GTTag Integer
, delta :: Discrete GTTag
-- ^ The amount of GT deposited or withdrawn from the Stake.
}
@ -143,7 +145,7 @@ stakeDepositWithdraw config =
, withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount)
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeBefore.stakedAmount)
)
, withDatum stakeAfter
, withRef stakeRef
@ -154,7 +156,7 @@ stakeDepositWithdraw config =
, withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount)
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeAfter.stakedAmount)
)
, withDatum stakeAfter
]

3
agora-specs/Sample/Stake/SetDelegate.hs
View file

@ -48,6 +48,7 @@ import PlutusLedgerApi.V2 (
)
import Sample.Shared (
agoraScripts,
fromDiscrete,
governor,
minAda,
signer,
@ -123,7 +124,7 @@ setDelegate ps = buildSpending' builder
[ st
, Value.assetClassValue
(untag governor.gtClassRef)
(untag stakeInput.stakedAmount)
(fromDiscrete stakeInput.stakedAmount)
, minAda
]

24
agora-specs/Spec/Proposal.hs
View file

@ -121,10 +121,6 @@ specs =
"duplicate cosigners"
Cosign.duplicateCosignersParameters
False
, Cosign.mkTestTree
"altered output stake"
Cosign.invalidStakeOutputParameters
False
, illegalStatusNotDraftGroup
]
in [legalGroup, illegalGroup]
@ -234,26 +230,6 @@ specs =
, forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True
}
, Advance.mkTestTree'
"altered output stake datum"
(\b -> unwords ["from", show b.proposalParameters.fromStatus])
(Advance.mkInvalidOutputStakeBundles cs es)
Advance.Validity
{ forProposalValidator = False
, forStakeValidator = False
, forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True
}
, Advance.mkTestTree'
"unexpected stake datum"
(\b -> unwords ["from", show b.proposalParameters.fromStatus])
(Advance.mkUnexpectedOutputStakeBundles cs es)
Advance.Validity
{ forProposalValidator = False
, forStakeValidator = True
, forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True
}
, Advance.mkTestTree
"forget to mint GATs"
(Advance.mkNoGATMintedBundle cs es)

7
agora-testlib/Test/Specification.hs
View file

@ -56,6 +56,7 @@ import Agora.Utils (
)
import Control.Composition ((.**), (.***))
import Data.Coerce (coerce)
import Data.Text qualified as Text
import Plutarch.Evaluate (evalScript)
import PlutusLedgerApi.V1.Scripts (
Context (..),
@ -137,8 +138,12 @@ toTestTree (Terminal (Specification name expectation script)) =
Failure -> onFailure
FailureWith s -> onFailureWith s
where
beautifyTraces =
Text.unpack
. Text.intercalate "\n"
. map (" " <>)
(res, _budget, traces) = evalScript script
ts = " Traces: " <> show traces
ts = " Traces:\n" <> beautifyTraces traces
onSuccess = case res of
Left e ->
assertFailure $

47
agora/Agora/Governor/Scripts.hs
View file

@ -21,8 +21,8 @@ import Agora.AuthorityToken (
singleAuthorityTokenBurned,
)
import Agora.Governor (
GovernorRedeemer (..),
PGovernorDatum (PGovernorDatum),
PGovernorRedeemer (..),
pgetNextProposalId,
pisGovernorDatumValid,
)
@ -36,7 +36,7 @@ import Agora.Proposal (
pneutralOption,
pwinner,
)
import Agora.Proposal.Time (createProposalStartingTime)
import Agora.Proposal.Time (validateProposalStartingTime)
import Agora.Scripts (
AgoraScripts,
authorityTokenSymbol,
@ -60,6 +60,7 @@ import Plutarch.Api.V1 (
PTokenName,
PValue (PValue),
)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V2 (
PAddress,
@ -71,13 +72,9 @@ import Plutarch.Api.V2 (
import Plutarch.Builtin (ppairDataBuiltin)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map (
plookup,
plookup',
)
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pmaybeData, pnothing)
import Plutarch.Extra.Map (ptryLookup)
import Plutarch.Extra.Maybe (passertPJust, pmaybeData, pnothing)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext (
pfindOutputsToAddress,
@ -90,7 +87,6 @@ import Plutarch.Extra.ScriptContext (
pvalueSpent,
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Extra.Tuple (pfstTuple, psndTuple)
import Plutarch.Extra.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
import PlutusLedgerApi.V1 (TxOutRef)
@ -253,6 +249,8 @@ governorValidator as =
plam $ \datum' redeemer' ctx' -> unTermCont $ do
ctxF <- pletAllC ctx'
redeemer <- pfromData . fst <$> ptryFromC redeemer'
txInfo' <- pletC $ pfromData $ ctxF.txInfo
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo'
@ -289,8 +287,8 @@ governorValidator as =
pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum
pure $
pmatchEnumFromData redeemer' $ \case
Just CreateProposal -> unTermCont $ do
pmatch redeemer $ \case
PCreateProposal -> unTermCont $ do
-- Check that the transaction advances proposal id.
let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId
@ -369,12 +367,7 @@ governorValidator as =
proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
let expectedStartingTime =
pfromJust #$ createProposalStartingTime
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange
expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
let expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
pguardC "Proposal datum correct" $
foldl1
@ -391,8 +384,11 @@ governorValidator as =
proposalOutputDatum.status #== pconstantData Draft
, ptraceIfFalse "cosigners correct" $
plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners
, ptraceIfFalse "starting time correct" $
proposalOutputDatum.startingTime #== expectedStartingTime
, ptraceIfFalse "starting time valid" $
validateProposalStartingTime
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange
# proposalOutputDatum.startingTime
, ptraceIfFalse "copy over configurations" $
proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds
#&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings
@ -435,7 +431,7 @@ governorValidator as =
--------------------------------------------------------------------------
Just MintGATs -> unTermCont $ do
PMintGATs -> unTermCont $ do
pguardC "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
-- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
@ -479,7 +475,7 @@ governorValidator as =
finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption
-- The effects of the winner outcome.
effectGroup <- pletC $ plookup' # finalResultTag #$ proposalInputDatumF.effects
effectGroup <- pletC $ ptryLookup # finalResultTag #$ proposalInputDatumF.effects
gatCount <- pletC $ plength #$ pto $ pto effectGroup
@ -520,7 +516,7 @@ governorValidator as =
let tagToken :: Term _ PTokenName
tagToken =
pmaybeData # pconstant "" # plam (pscriptHashToTokenName . pfromData)
#$ psndTuple # effect
#$ pfield @"scriptHash" # effect
receiverScriptHash =
passertPJust # "GAT receiver should be a script"
#$ pscriptHashFromAddress # outputF.address
@ -531,7 +527,7 @@ governorValidator as =
authorityTokens
#== psingleton # (ppairDataBuiltin # pdata tagToken # pdata 1)
hasCorrectDatum =
pfstTuple # effect #== pfromDatumHash # outputF.datum
pfield @"datumHash" # effect #== pfromDatumHash # outputF.datum
pure $
foldr1
@ -560,15 +556,12 @@ governorValidator as =
--------------------------------------------------------------------------
Just MutateGovernor -> unTermCont $ do
PMutateGovernor -> unTermCont $ do
-- Check that a GAT is burnt.
pguardC "One valid GAT burnt" $
singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint
pure $ popaque $ pconstant ()
--------------------------------------------------------------------------
Nothing -> ptraceError "Unknown redeemer"
where
-- The currency symbol of authority token.
atSymbol :: forall (s :: S). Term s PCurrencySymbol

96
agora/Agora/Proposal.hs
View file

@ -9,8 +9,7 @@ Proposal scripts encoding effects that operate on the system.
-}
module Agora.Proposal (
-- * Haskell-land
-- Proposal (..),
ProposalEffectMetadata (..),
ProposalEffectGroup,
ProposalDatum (..),
ProposalRedeemer (..),
@ -22,6 +21,7 @@ module Agora.Proposal (
emptyVotesFor,
-- * Plutarch-land
PProposalEffectMetadata (..),
PProposalEffectGroup,
PProposalDatum (..),
PProposalRedeemer (..),
@ -60,7 +60,6 @@ import Plutarch.Api.V2 (
PDatumHash,
PMaybeData,
PScriptHash,
PTuple,
)
import Plutarch.DataRepr (
DerivePConstantViaData (
@ -75,6 +74,7 @@ import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList),
DerivePConstantViaEnum (DerivePConstantEnum),
EnumIsData (EnumIsData),
PlutusTypeDataList,
PlutusTypeEnumData,
ProductIsData (ProductIsData),
)
@ -285,8 +285,35 @@ newtype ProposalVotes = ProposalVotes
emptyVotesFor :: forall a. StrictMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . StrictMap.mapWithKey (const . const 0)
-- | @since 0.3.0
type ProposalEffectGroup = StrictMap.Map ValidatorHash (DatumHash, Maybe ScriptHash)
-- | @since 1.0.0
data ProposalEffectMetadata = ProposalEffectMetadata
{ datumHash :: DatumHash
-- ^ Hash of datum sent to effect validator with GAT
, scriptHash :: Maybe ScriptHash
-- ^ A 'ScriptHash' that encodes the authority script.
}
deriving stock
( -- | @since 1.0.0
Generic
, -- | @since 1.0.0
Show
, -- | @since 1.0.0
Eq
)
deriving anyclass
( -- | @since 1.0.0
SOP.Generic
)
deriving
( -- | @since 1.0.0
PlutusTx.ToData
, -- | @since 1.0.0
PlutusTx.FromData
)
via (ProductIsData ProposalEffectMetadata)
-- | @since 1.0.0
type ProposalEffectGroup = StrictMap.Map ValidatorHash ProposalEffectMetadata
{- | Haskell-level datum for Proposal scripts.
@ -608,6 +635,52 @@ deriving via
instance
(PConstantDecl ProposalVotes)
{- | Plutarch-level version of 'ProposalEffectMetadata'.
@since 1.0.0
-}
newtype PProposalEffectMetadata (s :: S)
= PProposalEffectMetadata
( Term
s
( PDataRecord
'[ "datumHash" ':= PDatumHash
, "scriptHash" ':= PMaybeData (PAsData PScriptHash)
]
)
)
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
, -- | @since 1.0.0
PIsData
, -- | @since 1.0.0
PEq
, -- | @since 1.0.0
PDataFields
)
-- | @since 1.0.0
instance DerivePlutusType PProposalEffectMetadata where
type DPTStrat _ = PlutusTypeDataList
-- | @since 1.0.0
instance PUnsafeLiftDecl PProposalEffectMetadata where
type PLifted _ = ProposalEffectMetadata
-- | @since 1.0.0
deriving via
(DerivePConstantViaDataList ProposalEffectMetadata PProposalEffectMetadata)
instance
(PConstantDecl ProposalEffectMetadata)
-- | @since 1.0.0
instance PTryFrom PData (PAsData PProposalEffectMetadata)
{- | The effect script hashes and their associated datum hash and authority check script hash
belonging to a particular effect group or result.
@ -617,10 +690,7 @@ type PProposalEffectGroup =
PMap
'Sorted
PValidatorHash
( PTuple
PDatumHash
(PMaybeData (PAsData PScriptHash))
)
PProposalEffectMetadata
{- | Plutarch-level version of 'ProposalDatum'.
@ -655,14 +725,14 @@ newtype PProposalDatum (s :: S) = PProposalDatum
PEq
)
-- | @since 0.2.0
-- | @since 1.0.0
instance DerivePlutusType PProposalDatum where
type DPTStrat _ = PlutusTypeNewtype
type DPTStrat _ = PlutusTypeDataList
instance PTryFrom PData (PAsData PProposalDatum)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
instance PUnsafeLiftDecl PProposalDatum where type PLifted _ = ProposalDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
@ -735,7 +805,7 @@ pisEffectsVotesCompatible ::
:--> PBool
)
pisEffectsVotesCompatible = phoistAcyclic $
plam $ \((PM.pkeys #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) ->
plam $ \((PM.pkeys @PList #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) ->
plistEquals # effectKeys # voteKeys
{- | Retutns true if vote counts of /all/ the options are zero.

491
agora/Agora/Proposal/Scripts.hs
View file

@ -39,31 +39,41 @@ import Agora.Stake (
pisVoter,
)
import Agora.Utils (
plistEqualsBy,
pltAsData,
)
import Plutarch.Api.V1 (PCredential)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 (
PDatumHash,
PMintingPolicy,
PScriptContext (PScriptContext),
PScriptPurpose (PMinting, PSpending),
PTxInInfo,
PTxInfo (PTxInfo),
PTxOut,
PValidator,
)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.Category (PCategory (pidentity))
import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.List (pisUniq', pmapMaybe, pmergeBy, pmsortBy)
import Plutarch.Extra.Map (plookup, pupdate)
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pisJust)
import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Functor (pfmap)
import Plutarch.Extra.List (pfirstJust, pisUniq', pmergeBy, pmsort)
import Plutarch.Extra.Map (pupdate)
import Plutarch.Extra.Maybe (
passertPJust,
pfromJust,
pfromMaybe,
pisJust,
pjust,
pnothing,
)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext (
pfindTxInByTxOutRef,
pfromDatumHash,
pfromOutputDatum,
pisTokenSpent,
ptryFindDatum,
ptryFromOutputDatum,
)
import Plutarch.Extra.TermCont (
pguardC,
@ -124,6 +134,49 @@ proposalPolicy (AssetClass (govCs, govTn)) =
pure $ popaque (pconstant ())
{- | Validation context for redeemers which witness multiple stake in the reference
inputs.
@since 1.0.0
-}
data PWitnessMultipleStakeContext (s :: S) = PWitnessMultipleStakeContext
{ totalAmount :: Term s PInteger
, orderedOwners :: Term s (PList PCredential)
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType PWitnessMultipleStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | Validation context for redeemers which need to modify a single stake.
@since 1.0.0
-}
data PSpendSingleStakeContext (s :: S) = PSpendSingleStakeContext
{ inputStake :: Term s PStakeDatum
, outputStake :: Term s PStakeDatum
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType PSpendSingleStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | The validator for Proposals.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
@ -166,7 +219,8 @@ proposalValidator as maximumCosigners =
PTxInfo txInfo' <- pmatchC txInfo
txInfoF <-
pletFieldsC
@'[ "inputs"
@'[ "referenceInputs"
, "inputs"
, "outputs"
, "mint"
, "datums"
@ -176,7 +230,11 @@ proposalValidator as maximumCosigners =
txInfo'
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatchC $ pfromData ctx.purpose
PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs
PJust ((pfield @"resolved" #) -> txOut) <-
pmatchC $
pfindTxInByTxOutRef
# txOutRef
# txInfoF.inputs
txOutF <- pletFieldsC @'["address", "value"] $ txOut
proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum
@ -203,36 +261,44 @@ proposalValidator as maximumCosigners =
--
-- We match the proposal id here so that we can support multiple
-- proposal inputs in one thansaction.
ownOutput <-
pletC $
passertPJust # "Own output should be present" #$ pfind
# plam
( \input -> unTermCont $ do
inputF <- pletAllC input
-- TODO: this is highly inefficient: O(n) for every output,
-- Maybe we can cache the sorted datum map?
let datum =
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# inputF.datum
# txInfoF.datums
proposalId = pfield @"proposalId" # pto datum
pure $
inputF.address #== ownAddress
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
#&& proposalId #== proposalF.proposalId
)
# pfromData txInfoF.outputs
proposalOut <-
pletC $
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# (pfield @"datum" # ownOutput)
# txInfoF.datums
passertPJust
# "Own output should be present"
#$ pfirstJust
# plam
( flip pletAll $ \outputF ->
let isProposalUTxO =
foldl1
(#&&)
[ ptraceIfFalse "Own by proposal validator" $
outputF.address #== ownAddress
, ptraceIfFalse "Has proposal ST" $
psymbolValueOf # stCurrencySymbol # outputF.value #== 1
]
handleProposalUTxO = unTermCont $ do
-- Using inline datum to avoid O(n^2) lookup.
datum <-
pletC $
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# outputF.datum
# txInfoF.datums
pure $
pif
( pfield @"proposalId" # pto datum
#== proposalF.proposalId
)
(pjust # datum)
pnothing
in pif
isProposalUTxO
handleProposalUTxO
pnothing
)
# pfromData txInfoF.outputs
proposalUnchanged <- pletC $ proposalOut #== proposalDatum
@ -261,141 +327,130 @@ proposalValidator as maximumCosigners =
-- Find the stake inputs/outputs by SST.
let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as
stakeSTAssetClass <-
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
pletC $
plam $ \txOut -> unTermCont $ do
txOutF <- pletFieldsC @'["value", "datum"] txOut
pure $
pif
(passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1)
( let datumHash = pfromDatumHash # txOutF.datum
in pcon $ PJust $ pdata datumHash
)
(pcon PNothing)
plam $
flip (pletFields @'["value", "datum"]) $ \txOutF ->
let AssetClass (stakeSym, _) = stakeSTAssetClass as
stakeInputDatumHashes <-
pletC $
pmapMaybe @PBuiltinList
# plam ((filterStakeDatumHash #) . (pfield @"resolved" #))
# txInfoF.inputs
isStakeUTxO =
psymbolValueOf
# pconstant stakeSym
# txOutF.value
#== 1
stakeOutputDatumHashes <-
pletC $
pmapMaybe @PBuiltinList
# filterStakeDatumHash
# txInfoF.outputs
stake =
pfromData $
pfromJust
-- Use inline datum to avoid extra map lookup.
#$ ptryFromOutputDatum @(PAsData PStakeDatum)
# txOutF.datum
# txInfoF.datums
in pif isStakeUTxO (pjust # stake) pnothing
stakeInputNum <- pletC $ plength # stakeInputDatumHashes
pguardC "Every stake input should have a correspoding output" $
stakeInputNum #== plength # stakeOutputDatumHashes
----------------------------------------------------------------------------
withMultipleStakes' ::
witnessStakes' ::
Term
_
( ( PInteger
:--> PBuiltinList (PAsData PCredential)
:--> PUnit
)
:--> PUnit
s
( (PWitnessMultipleStakeContext :--> PUnit) :--> PUnit
) <-
pletC $
plam $ \validationLogic -> unTermCont $ do
-- The following code ensures that all the stake datums are not
-- changed.
--
-- TODO: This is quite inefficient (O(nlogn)) but for now we don't
-- have a nice way to check this. In plutus v2 we'll have map of
-- (Script -> Redeemer) in ScriptContext, which should be the
-- straight up solution.
let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData
let updateCtx = plam $ \ctx' stake -> unTermCont $ do
ctxF <- pmatchC ctx'
sortedStakeInputDatumHashes =
sortDatumHashes # stakeInputDatumHashes
stakeF <-
pletFieldsC @'["stakedAmount", "owner"] $
pto stake
sortedStakeOutputDatumHashes =
sortDatumHashes # stakeOutputDatumHashes
pure $
pcon $
PWitnessMultipleStakeContext
{ totalAmount =
ctxF.totalAmount
+ punsafeCoerce
(pfromData stakeF.stakedAmount)
, orderedOwners =
pcons # stakeF.owner
# ctxF.orderedOwners
}
pguardC "All stake datum are unchanged" $
plistEquals
# sortedStakeInputDatumHashes
# sortedStakeOutputDatumHashes
f :: Term _ (_ :--> PTxInInfo :--> _)
f = plam $ \ctx' ((pfield @"resolved" #) -> txOut) ->
pfromMaybe # ctx'
#$ (pfmap # (updateCtx # ctx') #$ getStakeDatum # txOut)
PPair totalStakedAmount stakeOwners <-
pmatchC $
pfoldl
# plam
( \l dh -> unTermCont $ do
let stake =
pfromData $
pfromJust
#$ ptryFindDatum @(PAsData PStakeDatum)
# pfromData dh
# txInfoF.datums
sortOwners = plam $
flip pmatch $ \ctxF ->
pcon $
PWitnessMultipleStakeContext
{ totalAmount = ctxF.totalAmount
, orderedOwners = pmsort # ctxF.orderedOwners
}
stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
ctx =
sortOwners
#$ pfoldl
# f
# pcon (PWitnessMultipleStakeContext 0 pnil)
# txInfoF.referenceInputs
in plam (# ctx)
PPair amount owners <- pmatchC l
let witnessStakes ::
( PWitnessMultipleStakeContext _ ->
TermCont _ ()
) ->
Term _ POpaque
witnessStakes c = popaque $
witnessStakes' #$ plam $ \sctxF ->
unTermCont $ pmatchC sctxF >>= c >> pure (pconstant ())
let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount)
updatedOwners = pcons # stakeF.owner # owners
pure $ pcon $ PPair newAmount updatedOwners
)
# pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList))
# stakeInputDatumHashes
sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners
pure $ validationLogic # totalStakedAmount # sortedStakeOwners
withSingleStake' ::
spendSingleStake' ::
Term
_
( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit
)
:--> PUnit
) <- pletC $
plam $ \validationLogic -> unTermCont $ do
pguardC "Can only deal with one stake" $
stakeInputNum #== 1
s
((PSpendSingleStakeContext :--> PUnit) :--> PUnit) <-
pletC $
let singleInput ::
Term
_
( PMaybe PStakeDatum
:--> PTxInInfo
:--> PMaybe PStakeDatum
)
singleInput = plam $ \l ((pfield @"resolved" #) -> txOut) ->
unTermCont $ do
lF <- pmatchC l
t <- pletC $ getStakeDatum # txOut
tF <- pmatchC t
stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
pure $ case (lF, tF) of
(PJust _, PJust _) ->
ptraceError "Can only deal with one stake"
(PNothing, _) -> t
(_, PNothing) -> l
stakeIn :: Term _ PStakeDatum <-
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
stakeInput =
passertPJust # "Stake input not found"
#$ pfoldl # singleInput # pnothing # txInfoF.inputs
stakeOut :: Term _ PStakeDatum <-
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
stakeOutput =
pfromJust
#$ pfirstJust # getStakeDatum # txInfoF.outputs
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
ctx = pcon $ PSpendSingleStakeContext stakeInput stakeOutput
in plam (# ctx)
pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged
let withMultipleStakes val =
withMultipleStakes'
#$ plam
$ \totalStakedAmount sortedStakeOwner ->
unTermCont $
val totalStakedAmount sortedStakeOwner
withSingleStake val =
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
stakeInF <- pletAllC $ pto stakeIn
val stakeInF stakeOut stakeUnchange
let spendSingleStake ::
( PSpendSingleStakeContext _ ->
TermCont _ ()
) ->
Term _ POpaque
spendSingleStake c = popaque $
spendSingleStake' #$ plam $ \sctx ->
unTermCont $ pmatchC sctx >>= c >> pure (pconstant ())
pure $
popaque $
pmatch proposalRedeemer $ \case
PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do
PCosign r -> witnessStakes $ \sctxF -> do
pguardC "Should be in draft state" $
currentStatus #== pconstant Draft
@ -417,7 +472,10 @@ proposalValidator as maximumCosigners =
pisUniq' # updatedSigs
pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # newSigs
plistEqualsBy
# plam (\x (pfromData -> y) -> x #== y)
# sctxF.orderedOwners
# newSigs
let expectedDatum =
mkRecordConstr
@ -435,11 +493,11 @@ proposalValidator as maximumCosigners =
pguardC "Signatures are correctly added to cosignature list" $
proposalOut #== expectedDatum
pure $ pconstant ()
----------------------------------------------------------------------
PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do
PVote r -> spendSingleStake $ \sctxF -> do
stakeInF <- pletAllC $ pto sctxF.inputStake
pguardC "Input proposal must be in VotingReady state" $
currentStatus #== pconstant VotingReady
@ -458,7 +516,7 @@ proposalValidator as maximumCosigners =
-- Ensure that no lock with the current proposal id has been put on the stake.
pguardC "Same stake shouldn't vote on the same proposal twice" $
pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # pfromData stakeInF.lockedBy
pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
let -- The amount of new votes should be the 'stakedAmount'.
-- Update the vote counter of the proposal, and leave other stuff as is.
@ -512,13 +570,13 @@ proposalValidator as maximumCosigners =
.& #lockedBy .= pdata expectedProposalLocks
)
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
pure $ pconstant ()
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== sctxF.outputStake
----------------------------------------------------------------------
PUnlock _ -> withSingleStake $ \stakeInF stakeOut _ -> do
PUnlock _ -> spendSingleStake $ \sctxF -> do
stakeInF <- pletAllC $ pto sctxF.inputStake
stakeRole <- pletC $ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
pguardC "Stake input should be relevant" $
@ -579,7 +637,7 @@ proposalValidator as maximumCosigners =
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed.
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto sctxF.outputStake
let templateStakeOut =
mkRecordConstr
@ -591,102 +649,99 @@ proposalValidator as maximumCosigners =
)
pguardC "Only locks updated in the output stake" $
templateStakeOut #== stakeOut
templateStakeOut #== sctxF.outputStake
pguardC "All relevant locks removed from the stake" $
validateOutputLocks # stakeOutputLocks
pure $ pconstant ()
----------------------------------------------------------------------
PAdvanceProposal _ -> unTermCont $ do
currentTime' <- pletC $ pfromJust # currentTime
let inDraftPeriod = isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inVotingPeriod = isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inExecutionPeriod = isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
pguardC "Only status changes in the output proposal" onlyStatusChanged
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved <-
pletC $
pany
# plam
( \( (pfield @"value" #)
. (pfield @"resolved" #) ->
value
) ->
psymbolValueOf # gstSymbol # value #== 1
)
# pfromData txInfoF.inputs
let toFailedState = unTermCont $ do
-- -> 'Finished'
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
pguardC "GST not moved" $ pnot # gstMoved
pure $ pconstant ()
pure $
pmatch currentStatus $ \case
PDraft ->
withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
pmatchC inDraftPeriod >>= \case
witnessStakes $ \sctxF -> do
let notTooLate = inDraftPeriod
pmatchC notTooLate >>= \case
PTrue -> do
pguardC "More cosigns than minimum amount" $
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
punsafeCoerce (pfromData thresholdsF.vote) #< sctxF.totalAmount
pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # proposalF.cosigners
plistEqualsBy
# plam (\x (pfromData -> y) -> x #== y)
# sctxF.orderedOwners
# proposalF.cosigners
-- 'Draft' -> 'VotingReady'
pguardC "Proposal status set to VotingReady" $
proposalOutStatus #== pconstant VotingReady
pure $ pconstant ()
PFalse -> do
pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished
pure $ pconstant ()
-- Too late: failed proposal, status set to 'Finished'.
PFalse ->
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
PVotingReady -> unTermCont $ do
let notTooLate = inLockedPeriod
notTooEarly = pnot # inVotingPeriod
pguardC "Cannot advance ahead of time" notTooEarly
-- FIXME: This should be checked by Stake, as opposed to here.
pguardC "No stakes must be present" $ stakeInputNum #== 0
pure $
pif
notTooLate
( unTermCont $ do
-- 'VotingReady' -> 'Locked'
pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstant Locked
pguardC "Winner outcome not found" $
pisJust #$ pwinner' # proposalF.votes
#$ punsafeCoerce
$ pfromData thresholdsF.execute
pmatchC notTooLate >>= \case
PTrue -> do
-- 'VotingReady' -> 'Locked'
pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstant Locked
pure $ pconstant ()
)
-- Too late: failed proposal, status set to 'Finished'.
toFailedState
pguardC "Winner outcome not found" $
pisJust #$ pwinner' # proposalF.votes
#$ punsafeCoerce
$ pfromData thresholdsF.execute
-- Too late: failed proposal, status set to 'Finished'.
PFalse ->
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
pure $ popaque $ pconstant ()
PLocked -> unTermCont $ do
let notTooLate = inExecutionPeriod
notTooEarly = pnot # inLockedPeriod
pguardC "Not too early" notTooEarly
pguardC "No stakes must be present" $ stakeInputNum #== 0
pure $
pguardC "Proposal status set to Finished" $
proposalOutStatus #== pconstant Finished
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved =
pany
# plam
( \( (pfield @"value" #)
. (pfield @"resolved" #) ->
value
) ->
psymbolValueOf # gstSymbol # value #== 1
)
# pfromData txInfoF.inputs
pguardC "GST not moved if too late, moved otherwise" $
pif
notTooLate
( unTermCont $ do
-- 'Locked' -> 'Finished'
pguardC "Proposal status set to Finished" $
proposalOutStatus #== pconstant Finished
-- Not too late: GST should moved
pidentity
-- Not too late: GST should not moved
pnot
# gstMoved
pguardC "GST moved" gstMoved
pure $ pconstant ()
)
toFailedState
pure $ popaque $ pconstant ()
PFinished -> ptraceError "Finished proposals cannot be advanced"

111
agora/Agora/Proposal/Time.hs
View file

@ -14,13 +14,13 @@ module Agora.Proposal.Time (
MaxTimeRangeWidth (..),
-- * Plutarch-land
PProposalTime (..),
PProposalTime,
PProposalTimingConfig (..),
PProposalStartingTime (..),
PMaxTimeRangeWidth (..),
-- * Compute periods given config and starting time.
createProposalStartingTime,
validateProposalStartingTime,
currentProposalTime,
isDraftPeriod,
isVotingPeriod,
@ -30,6 +30,7 @@ module Agora.Proposal.Time (
pisMaxTimeRangeWidthValid,
) where
import Agora.Utils (pcurrentTimeDuration)
import Control.Composition ((.*))
import Plutarch.Api.V1 (
PExtended (PFinite),
@ -44,10 +45,14 @@ import Plutarch.DataRepr (
PDataFields,
)
import Plutarch.Extra.Applicative (PApply (pliftA2))
import Plutarch.Extra.Bind ((#>>=))
import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Maybe (pjust, pnothing)
import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Extra.Time (
PCurrentTime (PCurrentTime),
pisCurrentTimeWithin,
pisWithinCurrentTime,
)
import Plutarch.Lift (
DerivePConstantViaNewtype (DerivePConstantViaNewtype),
PConstantDecl,
@ -160,23 +165,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
@since 0.1.0
-}
data PProposalTime (s :: S) = PProposalTime
{ lowerBound :: Term s PPOSIXTime
, upperBound :: Term s PPOSIXTime
}
deriving stock
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PEq
)
instance DerivePlutusType PProposalTime where
type DPTStrat _ = PlutusTypeScott
type PProposalTime = PCurrentTime
-- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@ -327,38 +316,41 @@ pisMaxTimeRangeWidthValid =
ptraceIfFalse "greater than 0"
. (pconstant (MaxTimeRangeWidth 0) #<)
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
{- | Validate starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
For every proposal, this is only meant to run once upon creation. Given time range should be
tight enough, meaning that the width of the time range should be less than the maximum value.
@since 0.1.0
@since 1.0.0
-}
createProposalStartingTime ::
validateProposalStartingTime ::
forall (s :: S).
Term
s
( PMaxTimeRangeWidth
:--> PPOSIXTimeRange
:--> PMaybe PProposalStartingTime
:--> PProposalStartingTime
:--> PBool
)
createProposalStartingTime = phoistAcyclic $
plam $ \(pto -> maxDuration) iv ->
let ct = currentProposalTime # iv
f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime)
f = plam $
flip pmatch $ \(PProposalTime lb ub) ->
let duration = ub - lb
startingTime = pdiv # (lb + ub) # 2
in pif
(duration #<= maxDuration)
(pjust #$ pcon $ PProposalStartingTime startingTime)
( ptrace
"createProposalStartingTime: given time range should be tight enough"
pnothing
)
in ct #>>= f
validateProposalStartingTime = phoistAcyclic $
plam $ \(pto -> maxDuration) iv (pto -> st) ->
pmaybe
# ptrace
"validateProposalStartingTime: unable to get current time"
(pconstant False)
# plam
( \ct ->
let duration = pcurrentTimeDuration # ct
isTightEnough =
ptraceIfFalse
"createProposalStartingTime: given time range should be tight enough"
$ duration #<= maxDuration
isInCurrentTimeRange =
ptraceIfFalse
"createProposalStartingTime: starting time should be in current time range"
$ pisWithinCurrentTime # st # ct
in isTightEnough #&& isInCurrentTimeRange
)
# (currentProposalTime # iv)
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
@ -389,32 +381,9 @@ currentProposalTime = phoistAcyclic $
lowerBound = getBound # lb
upperBound = getBound # ub
mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime
mkTime = phoistAcyclic $ plam $ pcon .* PCurrentTime
pure $ pliftA2 # mkTime # lowerBound # upperBound
{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
@since 0.1.0
-}
proposalTimeWithin ::
forall (s :: S).
Term
s
( PPOSIXTime
:--> PPOSIXTime
:--> PProposalTime
:--> PBool
)
proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> unTermCont $ do
PProposalTime ut lt <- pmatchC proposalTime'
pure $
foldr1
(#&&)
[ l #<= lt
, ut #<= h
]
{- | True if the 'PProposalTime' is in the draft period.
@since 0.1.0
@ -430,7 +399,7 @@ isDraftPeriod ::
)
isDraftPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + (pfield @"draftTime" # config))
pisCurrentTimeWithin # s # (s + (pfield @"draftTime" # config))
{- | True if the 'PProposalTime' is in the voting period.
@ -448,7 +417,7 @@ isVotingPeriod ::
isVotingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime)
{- | True if the 'PProposalTime' is in the locking period.
@ -466,7 +435,7 @@ isLockingPeriod ::
isLockingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
{- | True if the 'PProposalTime' is in the execution period.
@ -484,5 +453,5 @@ isExecutionPeriod ::
isExecutionPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
proposalTimeWithin # s
pisCurrentTimeWithin # s
# (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)

36
agora/Agora/Stake.hs
View file

@ -44,6 +44,7 @@ import Plutarch.DataRepr (
import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList),
PlutusTypeDataList,
ProductIsData (ProductIsData),
)
import Plutarch.Extra.List (pnotNull)
@ -51,10 +52,9 @@ import Plutarch.Extra.Sum (PSum (PSum))
import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import Plutarch.Orphans ()
import Plutarch.SafeMoney (PDiscrete)
import Plutarch.SafeMoney (Discrete, PDiscrete)
import PlutusLedgerApi.V2 (Credential)
import PlutusTx qualified
import Prelude hiding (Num (..))
--------------------------------------------------------------------------------
@ -123,7 +123,7 @@ PlutusTx.makeIsDataIndexed
{- | Haskell-level redeemer for Stake scripts.
@since 0.1.0
@since 1.0.0
-}
data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token.
@ -143,9 +143,6 @@ data StakeRedeemer
-- always allowed to have votes retracted and won't affect the Proposal datum,
-- allowing 'Stake's to be unlocked.
RetractVotes
| -- | The owner can consume stake if nothing is changed about it.
-- If the proposal token moves, this is equivalent to the owner consuming it.
WitnessStake
| -- | The owner can delegate the stake to another user, allowing the
-- delegate to vote on prooposals with the stake.
DelegateTo Credential
@ -164,9 +161,8 @@ PlutusTx.makeIsDataIndexed
, ('Destroy, 1)
, ('PermitVote, 2)
, ('RetractVotes, 3)
, ('WitnessStake, 4)
, ('DelegateTo, 5)
, ('ClearDelegate, 6)
, ('DelegateTo, 4)
, ('ClearDelegate, 5)
]
{- | Haskell-level datum for Stake scripts.
@ -174,7 +170,7 @@ PlutusTx.makeIsDataIndexed
@since 0.1.0
-}
data StakeDatum = StakeDatum
{ stakedAmount :: Tagged GTTag Integer
{ stakedAmount :: Discrete GTTag
-- ^ Tracks the amount of governance token staked in the datum.
-- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
, owner :: Credential
@ -238,24 +234,24 @@ newtype PStakeDatum (s :: S) = PStakeDatum
)
instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeNewtype
type DPTStrat _ = PlutusTypeDataList
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
-- | @since 1.0.0
instance PUnsafeLiftDecl PStakeDatum where
type PLifted PStakeDatum = StakeDatum
-- | @since 0.1.0
deriving via
(DerivePConstantViaDataList StakeDatum PStakeDatum)
instance
(Plutarch.Lift.PConstantDecl StakeDatum)
(PConstantDecl StakeDatum)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PStakeDatum)
{- | Plutarch-level redeemer for Stake scripts.
@since 0.1.0
@since 1.0.0
-}
data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token.
@ -264,7 +260,6 @@ data PStakeRedeemer (s :: S)
PDestroy (Term s (PDataRecord '[]))
| PPermitVote (Term s (PDataRecord '[]))
| PRetractVotes (Term s (PDataRecord '[]))
| PWitnessStake (Term s (PDataRecord '[]))
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
| PClearDelegate (Term s (PDataRecord '[]))
deriving stock
@ -280,6 +275,7 @@ data PStakeRedeemer (s :: S)
PIsData
)
-- | @since 0.2.0
instance DerivePlutusType PStakeRedeemer where
type DPTStrat _ = PlutusTypeData
@ -287,14 +283,14 @@ instance DerivePlutusType PStakeRedeemer where
instance PTryFrom PData PStakeRedeemer
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
instance PUnsafeLiftDecl PStakeRedeemer where
type PLifted PStakeRedeemer = StakeRedeemer
-- | @since 0.1.0
deriving via
(DerivePConstantViaData StakeRedeemer PStakeRedeemer)
instance
(Plutarch.Lift.PConstantDecl StakeRedeemer)
(PConstantDecl StakeRedeemer)
{- | Plutarch-level version of 'ProposalLock'.
@ -342,14 +338,14 @@ instance PTryFrom PData PProposalLock
instance PTryFrom PData (PAsData PProposalLock)
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
instance PUnsafeLiftDecl PProposalLock where
type PLifted PProposalLock = ProposalLock
-- | @since 0.1.0
deriving via
(DerivePConstantViaData ProposalLock PProposalLock)
instance
(Plutarch.Lift.PConstantDecl ProposalLock)
(PConstantDecl ProposalLock)
--------------------------------------------------------------------------------

503
agora/Agora/Stake/Scripts.hs
View file

@ -8,28 +8,30 @@ Plutus Scripts for Stakes.
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
import Agora.Credential (authorizationContext, pauthorizedBy)
import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
import Agora.Stake (
PStakeDatum (PStakeDatum),
PStakeRedeemer (..),
StakeRedeemer (WitnessStake),
pstakeLocked,
)
import Data.Function (on)
import Data.Tagged (Tagged, untag)
import Plutarch.Api.V1 (
PCredential (PPubKeyCredential, PScriptCredential),
PTokenName,
PValue,
)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 (
AmountGuarantees (Positive),
PDatumHash,
KeyGuarantees (Sorted),
PMaybeData,
PMintingPolicy,
PScriptPurpose (PMinting, PSpending),
PTxInInfo,
PTxInfo,
PTxOut,
PTxOutRef,
PValidator,
)
import Plutarch.Extra.AssetClass (
@ -37,23 +39,40 @@ import Plutarch.Extra.AssetClass (
passetClassValueOf,
pvalueOf,
)
import Plutarch.Extra.Bind (PBind ((#>>=)))
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pmaybeData)
import Plutarch.Extra.Functor (PFunctor (pfmap))
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Maybe (
passertPJust,
pdjust,
pdnothing,
pjust,
pmaybeData,
pnothing,
)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext (
pfindTxInByTxOutRef,
pfromDatumHash,
pfromOutputDatum,
pvalueSpent,
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Extra.TermCont (
pguardC,
pletC,
pletFieldsC,
pmatchC,
ptryFromC,
)
import Plutarch.Extra.Value (
pgeqByClass',
pgeqBySymbol,
psymbolValueOf,
)
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
import Plutarch.Numeric.Additive (
AdditiveMonoid (zero),
AdditiveSemigroup ((+)),
)
import Plutarch.SafeMoney (
pdiscreteValue',
pvalueDiscrete',
@ -178,6 +197,30 @@ stakePolicy gtClassRef =
--------------------------------------------------------------------------------
{- | Validation context for stake redeemers that allow only one stake to be
spent in the transaction.
@since 1.0.0
-}
data POnlyOneStakeContext (s :: S) = POnlyOneStakeContext
{ ownOutputDatum :: Term s PStakeDatum
, ownOutputValue :: Term s (PValue 'Sorted 'Positive)
, ownOutputValueUnchanged :: Term s PBool
, onlyLocksUpdated :: Term s PBool
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType POnlyOneStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | Validator intended for Stake UTXOs to be locked by.
== What this Validator does:
@ -247,6 +290,7 @@ stakeValidator as gtClassRef =
, "outputs"
, "signatories"
, "datums"
, "redeemers"
]
txInfo
@ -304,9 +348,33 @@ stakeValidator as gtClassRef =
_ -> unTermCont $ do
let AssetClass (propCs, propTn) = proposalSTAssetClass as
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
proposalTokenMoved <- pletC $ 1 #<= spentProposalST
proposalRedeemer <-
pletC $
let convertRedeemer = plam $ \(pto -> dt) ->
ptryFrom @PProposalRedeemer dt fst
findRedeemer = plam $ \ref ->
plookup
# pcon
( PSpending $
pdcons @_0
# pdata ref
# pdnil
)
# txInfoF.redeemers
f :: Term _ (PTxInInfo :--> PMaybe PTxOutRef)
f = plam $ \inInfo ->
let value = pfield @"value" #$ pfield @"resolved" # inInfo
ref = pfield @"outRef" # inInfo
in pif
(passetClassValueOf # value # proposalSTClass #== 1)
(pjust # ref)
pnothing
proposalRef = pfirstJust # f # txInfoF.inputs
in pfmap # convertRedeemer #$ proposalRef #>>= findRedeemer
-- Filter out own outputs using own address and ST.
ownOutputs <-
@ -322,234 +390,217 @@ stakeValidator as gtClassRef =
)
# pfromData txInfoF.outputs
let witnessStake = unTermCont $ do
pguardC "Either owner signs the transaction or proposal token moved" $
ownerSignsTransaction #|| proposalTokenMoved
-- FIXME: remove this once we have reference input.
--
-- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a
-- corresponding output stake, which carries the same value and the same datum as the input stake.
--
-- Validation strategy I have tried/considered so far:
-- 1. Check that the number of input stakes equals to the number of output stakes, and verify
-- that there's an output stake with the exact same value and datum hash as the stake being
-- validated , However this approach has a fatal vulnerability: let's say we have two totally
-- identical stakes, a malicious user can comsume these two stakes and remove GTs from one of them.
-- 2. Perform the same checks as the last approch does, while also checking that every output stake is
-- valid(stakedAmount == actual value). However this requires that all the output stake datum are
-- included in the transaction, and we have to find and go through them one by one to access the
-- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive.
-- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and
-- ensure that the two sorted lists are equal.
let ownInputs =
pmapMaybe
# plam
( \input -> plet (pfield @"resolved" # input) $ \resolvedInput ->
let value = pfield @"value" # resolvedInput
in pif
(psymbolValueOf # stCurrencySymbol # value #== 1)
(pcon $ PJust resolvedInput)
(pcon PNothing)
)
# pfromData txInfoF.inputs
sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
where
getDatumHash :: Term _ (PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDatumHash #) . (pfield @"datum" #))
sortedOwnInputs = sortTxOuts # ownInputs
sortedOwnOutputs = sortTxOuts # ownOutputs
pguardC "Every stake inputs has a corresponding unchanged output" $
plistEquals # sortedOwnInputs # sortedOwnOutputs
pure $ popaque $ pconstant ()
----------------------------------------------------------------------
let onlyAcceptOneStake = unTermCont $ do
withSingleStake' ::
Term
s
( (POnlyOneStakeContext :--> PUnit)
:--> POpaque
) <-
pletC $
plam $ \validationLogic -> unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
ownOutput <- pletC $ phead # ownOutputs
stakeOut <-
pletC $
pfromData $
pfromOutputDatum @(PAsData PStakeDatum)
# (pfield @"datum" # ownOutput)
# txInfoF.datums
let ownOutputDatum =
pfromData $
pfromOutputDatum @(PAsData PStakeDatum)
# (pfield @"datum" # ownOutput)
# txInfoF.datums
ownOutputValue <-
pletC $
pfield @"value" # ownOutput
ownOutputValue =
pfield @"value" # ownOutput
ownOutputValueUnchanged <-
pletC $
pdata resolvedF.value #== pdata ownOutputValue
ownOutputValueUnchanged =
pdata resolvedF.value #== pdata ownOutputValue
onlyLocksUpdated <-
pletC $
let templateStakeDatum =
mkRecordConstr
onlyLocksUpdated =
let templateStakeDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy"
# pto ownOutputDatum
)
in ownOutputDatum #== templateStakeDatum
ctx =
pcon $
POnlyOneStakeContext
ownOutputDatum
ownOutputValue
ownOutputValueUnchanged
onlyLocksUpdated
pure $ popaque $ validationLogic # ctx
let withSingleStake val = withSingleStake' #$ plam $ \ctx ->
unTermCont $ do
ctxF <- pmatchC ctx
val ctxF
pure $ pconstant ()
setDelegate :: Term s (PMaybeData (PAsData PCredential) :--> POpaque) <-
pletC $
plam $ \maybePkh -> withSingleStake $ \ctx -> do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "Cannot delegate to the owner" $
pmaybeData
# pcon PTrue
# plam (\pkh -> pnot #$ stakeDatum.owner #== pkh)
# maybePkh
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum =
ctx.ownOutputDatum
#== mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut
.& #delegatedTo .= pdata maybePkh
.& #lockedBy .= stakeDatum.lockedBy
)
in stakeOut #== templateStakeDatum
setDelegate <- pletC $
plam $ \maybePkh -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum =
stakeOut
#== mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= pdata maybePkh
.& #lockedBy .= stakeDatum.lockedBy
)
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $ popaque (pconstant ())
pure $
pmatch stakeRedeemer $ \case
PRetractVotes _ -> unTermCont $ do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" proposalTokenMoved
pguardC "A UTXO must exist with the correct output" $
let valueCorrect = ownOutputValueUnchanged
outputDatumCorrect = onlyLocksUpdated
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
pure $ popaque (pconstant ())
------------------------------------------------------------
PPermitVote _ -> unTermCont $ do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
let proposalTokenMinted =
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent or minted" $
proposalTokenMoved #|| proposalTokenMinted
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = onlyLocksUpdated
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $ popaque (pconstant ())
------------------------------------------------------------
PDepositWithdraw r -> unTermCont $ do
pguardC "Stake unlocked" $
pnot #$ stakeIsLocked
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
unTermCont $ do
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
delta = pfromData $ pfield @"delta" # r
newStakedAmount <- pletC $ oldStakedAmount + delta
pguardC "New staked amount should be greater than or equal to 0" $
zero #<= newStakedAmount
let expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= pdata newStakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
--
pure $ popaque (pconstant ())
------------------------------------------------------------
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) -> unTermCont $ do
pguardC "Cannot delegate to the owner" $
pnot #$ stakeDatum.owner #== pkh
pure $ setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------
PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------
_ -> popaque (pconstant ())
valueCorrect = ctx.ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $
pif
(pdata stakeRedeemer #== pconstantData WitnessStake)
witnessStake
onlyAcceptOneStake
pmatch stakeRedeemer $ \case
PRetractVotes _ -> withSingleStake $ \ctx -> do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" $
pmatch proposalRedeemer $ \case
PJust redeemer -> pmatch redeemer $ \case
PUnlock _ -> pconstant True
_ ->
ptrace "Expected PUnlock, but got other" $
pconstant False
PNothing ->
ptrace "Proposal redeemer not found" $
pconstant False
pguardC "A UTXO must exist with the correct output" $
let valueCorrect = ctx.ownOutputValueUnchanged
outputDatumCorrect = ctx.onlyLocksUpdated
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
------------------------------------------------------------------
PPermitVote _ -> withSingleStake $ \ctx -> do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
let proposalTokenMinted =
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent or minted" $
pmatch
proposalRedeemer
( \case
PJust proposalRedeemer' ->
pmatch proposalRedeemer' $ \case
PVote _ -> pconstant True
_ -> ptrace "Expected PVote" $ pconstant False
_ -> proposalTokenMinted
)
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = ctx.onlyLocksUpdated
valueCorrect = ctx.ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
------------------------------------------------------------------
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) ->
setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------------
PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------------
PDepositWithdraw r -> withSingleStake $ \ctx -> do
pguardC "Stake unlocked" $
pnot #$ stakeIsLocked
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
unTermCont $ do
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
delta = pfromData $ pfield @"delta" # r
newStakedAmount <- pletC $ oldStakedAmount + delta
pguardC "New staked amount should be greater than or equal to 0" $
zero #<= newStakedAmount
let expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= pdata newStakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = ctx.ownOutputDatum #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ctx.ownOutputValue
# expectedValue
, pgeqByClass' (untag gtClassRef)
# ctx.ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ctx.ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
------------------------------------------------------------------
_ -> ptraceError "unreachable"

64
agora/Agora/Utils.hs
View file

@ -18,10 +18,17 @@ module Agora.Utils (
pvalidatorHashToTokenName,
pscriptHashToTokenName,
scriptHashToTokenName,
plistEqualsBy,
pstringIntercalate,
punwords,
pcurrentTimeDuration,
) where
import Plutarch.Api.V1 (PTokenName, PValidatorHash)
import Plutarch.Api.V1 (PPOSIXTime, PTokenName, PValidatorHash)
import Plutarch.Api.V2 (PScriptHash)
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
import Plutarch.List (puncons)
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V2 (
Address (Address),
@ -128,3 +135,58 @@ newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
newtype CompiledEffect (datum :: Type) = CompiledEffect
{ getCompiledEffect :: Validator
}
-- | @since 1.0.0
plistEqualsBy ::
forall
(list1 :: PType -> PType)
(list2 :: PType -> PType)
(a :: PType)
(b :: PType)
(s :: S).
(PIsListLike list1 a, PIsListLike list2 b) =>
Term s ((a :--> b :--> PBool) :--> list1 a :--> (list2 b :--> PBool))
plistEqualsBy = phoistAcyclic $ pfix # go
where
go = plam $ \self eq l1 l2 -> unTermCont $ do
l1' <- pmatchC $ puncons # l1
l2' <- pmatchC $ puncons # l2
case (l1', l2') of
(PJust l1'', PJust l2'') -> do
(PPair h1 t1) <- pmatchC l1''
(PPair h2 t2) <- pmatchC l2''
pure $ eq # h1 # h2 #&& self # eq # t1 # t2
(PNothing, PNothing) -> pure $ pconstant True
_ -> pure $ pconstant False
-- | @since 1.0.0
pstringIntercalate ::
forall (s :: S).
Term s PString ->
[Term s PString] ->
Term s PString
pstringIntercalate _ [x] = x
pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
pstringIntercalate _ _ = ""
-- | @since 1.0.0
punwords ::
forall (s :: S).
[Term s PString] ->
Term s PString
punwords = pstringIntercalate " "
-- | @since 1.0.0
pcurrentTimeDuration ::
forall (s :: S).
Term
s
( PCurrentTime
:--> PPOSIXTime
)
pcurrentTimeDuration = phoistAcyclic $
plam $
flip pmatch $
\(PCurrentTime lb ub) -> ub - lb

1092
bench.csv
View file

File diff suppressed because it is too large Load diff

1186
flake.lock generated
View file

File diff suppressed because it is too large Load diff

2
flake.nix
View file

@ -15,7 +15,7 @@
# Plutarch and its friends
plutarch = {
url = "github:Plutonomicon/plutarch-plutus?ref=staging";
url = "github:Plutonomicon/plutarch-plutus?ref=master";
inputs.emanote.follows =
"plutarch/haskell-nix/nixpkgs-unstable";