diff --git a/agora-specs/Sample/Proposal/Vote.hs b/agora-specs/Sample/Proposal/Vote.hs index 2246894..2a138b8 100644 --- a/agora-specs/Sample/Proposal/Vote.hs +++ b/agora-specs/Sample/Proposal/Vote.hs @@ -1,3 +1,9 @@ +{- | +Module : Sample.Proposal.Vote +Maintainer : connor@mlabs.city +Description: Generate sample data for testing the functionalities of voting on proposals. +Sample and utilities for testing the functionalities of voting on proposals. +-} module Sample.Proposal.Vote ( ParameterBundle (..), VoteParameters (..), diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index f9d9b9c..63129ed 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -183,6 +183,7 @@ instance DerivePlutusType PStakeInputsContext where When voting and unlocking, the proposal must witness a state transition occuring in the relevant Stake. This transition must place a lock on the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'. + Note that only one proposal per transaction is supported. === Periods diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index e08d89d..b5b3aab 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -458,10 +458,13 @@ data PSignedBy (s :: S) instance DerivePlutusType PSignedBy where type DPTStrat _ = PlutusTypeScott --- | @since 1.0.0 +{- | The signature context. + + @since 1.0.0 +-} data PSigContext (s :: S) = PSigContext { owner :: Term s PCredential - , delegate :: Term s (PMaybeData (PAsData PCredential)) + , delegatee :: Term s (PMaybeData (PAsData PCredential)) , signedBy :: Term s PSignedBy } deriving stock @@ -562,7 +565,8 @@ instance DerivePlutusType PStakeRedeemerHandlerContext where -} type PStakeRedeemerHandler = PStakeRedeemerHandlerContext :--> PUnit -{- | Newtype wrapper around @'ClosedTerm' 'PStakeRedeemerHandler'@ to allow type inference to work. +{- | Newtype wrapper around @'ClosedTerm' 'PStakeRedeemerHandler'@ to allow type + inference to work. @since 1.0.0 -} @@ -570,6 +574,7 @@ newtype PStakeRedeemerHandlerTerm = PStakeRedeemerHandlerTerm (ClosedTerm PStakeRedeemerHandler) +-- | @since 1.0.0 runStakeRedeemerHandler :: PStakeRedeemerHandlerTerm -> ClosedTerm PStakeRedeemerHandler diff --git a/agora/Agora/Stake/Redeemers.hs b/agora/Agora/Stake/Redeemers.hs index 7e8dafb..2a0316b 100644 --- a/agora/Agora/Stake/Redeemers.hs +++ b/agora/Agora/Stake/Redeemers.hs @@ -58,6 +58,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+))) import Prelude hiding (Num ((+))) +-- | A wrapper which ensures that no proposal is presented in the transaction. pwithoutProposal :: forall (s :: S). Term @@ -73,6 +74,9 @@ pwithoutProposal = phoistAcyclic $ (f # ctx) (ptraceError "No proposal is allowed") +{- | Validate stake outputs given a function that converts an input stake datum + to an ouput stake datum. / O(n^2) /. +-} pbatchUpdateInputs :: forall (s :: S). Term @@ -88,6 +92,7 @@ pbatchUpdateInputs = phoistAcyclic $ # ctxF.stakeOutputDatums # ctxF.stakeInputDatums +-- | Extract the 'PSigContext.signedBy' field from 'PStakeRedeemerHandlerContext'. pgetSignedBy :: forall (s :: S). Term @@ -99,15 +104,16 @@ pgetSignedBy = phoistAcyclic $ sctxF <- pmatchC ctxF.sigContext pure sctxF.signedBy +-- | Return true if the tx is authorized by either the owner or the delegatee. pisSignedBy :: forall (s :: S). Term s - (PBool :--> PBool :--> PStakeRedeemerHandlerContext :--> PBool) + (PBool :--> PStakeRedeemerHandlerContext :--> PBool) pisSignedBy = phoistAcyclic $ - plam $ \byOwner byDelegate ctx -> + plam $ \byDelegate ctx -> pmatch (pgetSignedBy # ctx) $ \case - PSignedByOwner -> byOwner + PSignedByOwner -> pconstant True PSignedByDelegate -> byDelegate PUnknownSig -> pconstant False @@ -154,7 +160,7 @@ pvoteHelper = phoistAcyclic $ ctxF <- pmatchC ctx pguardC "Owner or delegate signs this transaction" $ - pisSignedBy # pconstant True # pconstant True # ctx + pisSignedBy # pconstant True # ctx -- This puts trust into the Proposal. The Proposal must necessarily check -- that this is not abused. @@ -164,6 +170,7 @@ pvoteHelper = phoistAcyclic $ pure $ pconstant () +-- | Add new lock the the existing list of locked. paddNewLock :: forall (s :: S). Term @@ -172,7 +179,10 @@ paddNewLock :: :--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock) ) -paddNewLock = phoistAcyclic $ plam $ \newLock -> pcons # pdata newLock +paddNewLock = phoistAcyclic $ + plam $ + -- Prepend the lock. + \newLock -> pcons # pdata newLock {- | Default implementation of 'Agora.Stake.PermitVote'. @@ -201,11 +211,15 @@ ppermitVote = pvoteHelper #$ phoistAcyclic $ in paddNewLock # newLock _ -> ptraceError "Expected proposal" +{- | Remove stake locks with the proposal id given the list of existing locks. + The first parameter controls whether to revmove creator locks or not. +-} premoveLocks :: forall (s :: S). Term s - ( PProposalId :--> PBool + ( PProposalId + :--> PBool :--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock) ) @@ -248,7 +262,7 @@ pdelegateHelper = phoistAcyclic $ sigCtxF <- pmatchC ctxF.sigContext pguardC "Owner signs this transaction" $ - pisSignedBy # pconstant True # pconstant False # ctx + pisSignedBy # pconstant False # ctx let newDelegate = f # ctxF.redeemerContext @@ -307,7 +321,7 @@ pdestroy = phoistAcyclic $ ctxF <- pmatchC ctx pguardC "Owner signs this transaction" $ - pisSignedBy # pconstant True # pconstant False # ctx + pisSignedBy # pconstant False # ctx pguardC "Stake unlocked" $ pnot #$ pany # pstakeLocked # ctxF.stakeInputDatums @@ -324,7 +338,7 @@ pdepositWithdraw = phoistAcyclic $ ctxF <- pmatchC ctx pguardC "Owner signs this transaction" $ - pisSignedBy # pconstant True # pconstant False # ctx + pisSignedBy # pconstant False # ctx ---------------------------------------------------------------------------- diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 2a1d509..0948dbc 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -74,7 +74,6 @@ import Plutarch.Api.V2 ( AmountGuarantees, PMintingPolicy, PScriptPurpose (PMinting, PSpending), - PTxInInfo, PTxInfo, PTxOut, PValidator, @@ -289,6 +288,7 @@ mkStakeValidator -------------------------------------------------------------------------- + -- Returns stake datum if the given UTxO is a stake UTxO. getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <- pletC $ plam $ \txOut -> unTermCont $ do @@ -314,6 +314,8 @@ mkStakeValidator -------------------------------------------------------------------------- + -- Find all stake inputs. + stakeInputDatums <- pletC $ pmapMaybe @@ -322,6 +324,8 @@ mkStakeValidator -------------------------------------------------------------------------- + -- Assemble the signature context. + firstStakeInputDatumF <- pletFieldsC @'["owner", "delegatedTo"] $ phead # stakeInputDatums @@ -372,8 +376,14 @@ mkStakeValidator -------------------------------------------------------------------------- + -- Find all stake outputs. + let gtAssetClass = passetClass # pconstant gtSym # pconstant gtTn + -- First step of validating stake outputs. We make sure that every stake + -- output UTxO carries correct amount of GTs specified by its datum. + -- + -- Note that non-GT assets are treated transparently. stakeOutputDatums <- pletC $ pmapMaybe @@ -381,6 +391,7 @@ mkStakeValidator ( \output -> let validateGT = plam $ \stakeDatum -> let expected = pfield @"stakedAmount" # stakeDatum + actual = pvalueDiscrete # gtAssetClass @@ -459,7 +470,6 @@ mkStakeValidator ) # txInfoF.redeemers - getContext :: Term _ (PTxInInfo :--> PMaybe PProposalContext) getContext = plam $ flip pletAll $ \inInfoF -> pfmap @@ -475,7 +485,8 @@ mkStakeValidator contexts = pmapMaybe @PList # getContext # pfromData txInfoF.inputs - in precList + in -- Can only handle one proposal at a time. + precList ( \_ h t -> pif (pnull # t) @@ -519,7 +530,7 @@ mkStakeValidator -- Call the redeemer handler. - stakeRedeemer :: Term _ PStakeRedeemer <- fst <$> ptryFromC redeemer + stakeRedeemer <- fst <$> ptryFromC redeemer pure $ popaque $ @@ -546,6 +557,7 @@ mkStakeValidator Deposit or withdraw some GT to the stake. + - Only one stake per tx is supported. - Tx must be signed by the owner. - The 'stakedAmount' field must be updated. - The stake must not be locked. @@ -557,9 +569,9 @@ mkStakeValidator Allow a 'ProposalLock' to be put on the stake in order to vote on a proposal. - - A proposal token must be spent alongside the stake. + - A proposal token must be spent alongside the staked. - * Its total votes must be correctly updated to include this stake's + * Its total votes must be correctly updated to include all stakes' contribution. - Tx must be signed by the owner. @@ -568,14 +580,14 @@ mkStakeValidator Remove a 'ProposalLock' set when voting on a proposal. - - A proposal token must be spent alongside the stake. + - A proposal token must be spent or minted alongside the stakes. - Tx must be signed by the owner. === 'Destroy' - Destroy the stake in order to reclaim the min ADA. + Destroy stakes in order to reclaim the GTs. - - The stake must not be locked. + - The stakes must not be locked. - Tx must be signed by the owner. @since 0.1.0 diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index d033544..61fc2e6 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -237,7 +237,11 @@ pisSingleton = (\_ _ t -> pnull # t) (const $ pconstant False) --- | @since 1.0.0 +{- Throws an error if the given list contains zero or more than one elements. + Otherwise returns the only element. + + @since 1.0.0 +-} pfromSingleton :: forall (a :: PType) (list :: PType -> PType) (s :: S). (PIsListLike list a) => @@ -253,7 +257,11 @@ pfromSingleton = ) (const $ ptraceError "Empty list") --- | @since 1.0.0 +{- | A version of 'pmap' which can throw out elements and change the list type + along the way. + + @since 1.0.0 +-} pmapMaybe :: forall (listO :: PType -> PType)