Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

place a lock on the stake while cosigning

Browse source
This commit is contained in:
Hongrui Fang 2022-10-03 21:25:26 +08:00
parent ed3962cb63
commit c65bf3e6d2
5 changed files with 283 additions and 184 deletions
Download patch file Download diff file Expand all files Collapse all files

21
agora/Agora/Proposal.hs
View file

@ -235,6 +235,8 @@ data ProposalThresholds = ProposalThresholds
-- ^ How much GT required to to move into 'Locked'. -- ^ How much GT required to to move into 'Locked'.
, vote :: Tagged GTTag Integer , vote :: Tagged GTTag Integer
-- ^ How much GT required to vote on a outcome. -- ^ How much GT required to vote on a outcome.
, cosign :: Tagged GTTag Integer
-- ^ How much GT required to cosign a proposal.
} }
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -366,20 +368,18 @@ data ProposalDatum = ProposalDatum
{- | Haskell-level redeemer for Proposal scripts. {- | Haskell-level redeemer for Proposal scripts.
@since 0.1.0 @since 1.0.0
-} -}
data ProposalRedeemer data ProposalRedeemer
= -- | Cast one or more votes towards a particular 'ResultTag'. = -- | Cast one or more votes towards a particular 'ResultTag'.
Vote ResultTag Vote ResultTag
| -- | Add one or more public keys to the cosignature list. | -- | Add a credential to the cosignature list.
-- Must be signed by those cosigning. -- Must be authorized by the stake owner.
-- --
-- This is particularly used in the 'Draft' 'ProposalStatus', -- This is particularly used in the 'Draft' 'ProposalStatus',
-- where matching 'Agora.Stake.Stake's can be called to advance the proposal, -- where matching 'Agora.Stake.Stake's can be witnessed to advance the
-- provided enough GT is shared among them. -- proposal, provided enough GT is shared among them.
-- Cosign
-- This list should be sorted in ascending order.
Cosign [Credential]
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
Unlock Unlock
| -- | Advance the proposal, performing the required checks for whether that is legal. | -- | Advance the proposal, performing the required checks for whether that is legal.
@ -564,6 +564,7 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
, "create" ':= PDiscrete GTTag , "create" ':= PDiscrete GTTag
, "toVoting" ':= PDiscrete GTTag , "toVoting" ':= PDiscrete GTTag
, "vote" ':= PDiscrete GTTag , "vote" ':= PDiscrete GTTag
, "cosign" ':= PDiscrete GTTag
] ]
) )
} }
@ -748,7 +749,7 @@ deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance
-} -}
data PProposalRedeemer (s :: S) data PProposalRedeemer (s :: S)
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag])) = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PCredential)])) | PCosign (Term s (PDataRecord '[]))
| PUnlock (Term s (PDataRecord '[])) | PUnlock (Term s (PDataRecord '[]))
| PAdvanceProposal (Term s (PDataRecord '[])) | PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock deriving stock
@ -964,6 +965,8 @@ pisProposalThresholdsValid = phoistAcyclic $
0 #<= pfromData thresholdsF.toVoting 0 #<= pfromData thresholdsF.toVoting
, ptraceIfFalse "Vote threshold is less than or equal to 0" $ , ptraceIfFalse "Vote threshold is less than or equal to 0" $
0 #<= pfromData thresholdsF.vote 0 #<= pfromData thresholdsF.vote
, ptraceIfFalse "Cosign threshold is less than or equal to 0" $
0 #<= pfromData thresholdsF.cosign
] ]
{- | Retract votes given the option and the amount of votes. {- | Retract votes given the option and the amount of votes.

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

@ -10,7 +10,6 @@ module Agora.Proposal.Scripts (
proposalPolicy, proposalPolicy,
) where ) where
import Agora.Credential (authorizationContext, pauthorizedBy)
import Agora.Proposal ( import Agora.Proposal (
PProposalDatum (PProposalDatum), PProposalDatum (PProposalDatum),
PProposalRedeemer (PAdvanceProposal, PCosign, PUnlock, PVote), PProposalRedeemer (PAdvanceProposal, PCosign, PUnlock, PVote),
@ -31,12 +30,13 @@ import Agora.Scripts (AgoraScripts, governorSTSymbol, proposalSTSymbol, stakeSTA
import Agora.Stake ( import Agora.Stake (
PStakeDatum, PStakeDatum,
pextractVoteOption, pextractVoteOption,
pgetStakeRole, pgetStakeRoles,
pisIrrelevant, pisIrrelevant,
pisPureCreator,
pisVoter, pisVoter,
) )
import Agora.Utils ( import Agora.Utils (
pfromSingleton,
pinsertUniqueBy,
plistEqualsBy, plistEqualsBy,
pmapMaybe, pmapMaybe,
) )
@ -64,7 +64,7 @@ import Plutarch.Extra.Maybe (
pmaybe, pmaybe,
pnothing, pnothing,
) )
import Plutarch.Extra.Ord (pallUnique, pfromOrdBy, psort, ptryMergeBy) import Plutarch.Extra.Ord (pfromOrdBy, psort)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext ( import Plutarch.Extra.ScriptContext (
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
@ -226,8 +226,6 @@ proposalValidator as maximumCosigners =
currentTime <- pletC $ currentProposalTime # txInfoF.validRange currentTime <- pletC $ currentProposalTime # txInfoF.validRange
authorizedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
PSpending ((pfield @"_0" #) -> propsalInputRef) <- PSpending ((pfield @"_0" #) -> propsalInputRef) <-
@ -406,38 +404,30 @@ proposalValidator as maximumCosigners =
pure $ pure $
popaque $ popaque $
pmatch proposalRedeemer $ \case pmatch proposalRedeemer $ \case
PCosign r -> witnessStakes $ \sctxF -> do PCosign _ -> spendStakes $ \sctxF -> do
pguardC "Should be in draft state" $ pguardC "Should be in draft state" $
currentStatus #== pconstant Draft currentStatus #== pconstant Draft
newSigs <- pletC $ pfield @"newCosigners" # r stakeF <-
pletFieldsC @'["owner", "stakedAmount"] $
ptrace "Exactly one stake input" $
pfromSingleton # sctxF.inputStakes
pguardC "Signed by all new cosigners" $ let newCosigner = stakeF.owner
pall # plam ((authorizedBy #) . pfromData) # newSigs
-- Assuming that new signatures encoded in the redeemer and exsiting
-- cosigners are sorted in ascending order, the new list of
-- signatures will be ordered.
updatedSigs <- updatedSigs <-
pletC $ pletC $
ptryMergeBy # (pfromOrdBy # plam pfromData) ptrace "Update signature set" $
# newSigs pinsertUniqueBy
# proposalInputDatumF.cosigners # (pfromOrdBy # plam pfromData)
# newCosigner
# proposalInputDatumF.cosigners
pguardC "Less cosigners than maximum limit" $ pguardC "Less cosigners than maximum limit" $
plength # updatedSigs #< pconstant maximumCosigners plength # updatedSigs #< pconstant maximumCosigners
-- assuming sigs are sorted pguardC "Meet minimum GT requirement" $
PJust cosUnique <- pmatchC $ pallUnique #$ pmap # plam pfromData # updatedSigs pfromData thresholdsF.cosign #<= stakeF.stakedAmount
pguardC "Cosigners are unique" cosUnique
pguardC "All new cosigners are witnessed by their Stake datums" $
-- Also, this ensures that the cosigners field in the output
-- propopsal datum is ordered.
plistEqualsBy
# plam (\x (pfromData -> y) -> x #== y)
# sctxF.orderedOwners
# newSigs
let expectedDatum = let expectedDatum =
mkRecordConstr mkRecordConstr
@ -469,7 +459,7 @@ proposalValidator as maximumCosigners =
pguardC "Same stake shouldn't vote on the same proposal twice" $ pguardC "Same stake shouldn't vote on the same proposal twice" $
pnot pnot
#$ pisVoter #$ pisVoter
#$ pgetStakeRole #$ pgetStakeRoles
# proposalInputDatumF.proposalId # proposalInputDatumF.proposalId
# stakeF.lockedBy # stakeF.lockedBy
@ -542,17 +532,17 @@ proposalValidator as maximumCosigners =
@'["stakedAmount", "lockedBy"] @'["stakedAmount", "lockedBy"]
stake stake
stakeRole <- stakeRoles <-
pletC $ pletC $
pgetStakeRole pgetStakeRoles
# proposalInputDatumF.proposalId # proposalInputDatumF.proposalId
# stakeF.lockedBy # stakeF.lockedBy
pguardC "Stake input should be relevant" $ pguardC "Stake input should be relevant" $
pnot #$ pisIrrelevant # stakeRole pnot #$ pisIrrelevant # stakeRoles
let canRetractVotes = let canRetractVotes =
pnot #$ pisPureCreator # stakeRole pisVoter # stakeRoles
voteCount = voteCount =
pextract pextract
@ -561,7 +551,7 @@ proposalValidator as maximumCosigners =
newVotes = newVotes =
pretractVotes pretractVotes
# (pextractVoteOption # stakeRole) # (pextractVoteOption # stakeRoles)
# voteCount # voteCount
# votes # votes

192
agora/Agora/Stake.hs
View file

@ -34,10 +34,10 @@ module Agora.Stake (
pstakeLocked, pstakeLocked,
pnumCreatedProposals, pnumCreatedProposals,
pextractVoteOption, pextractVoteOption,
pgetStakeRole, pgetStakeRoles,
pisVoter, pisVoter,
pisCreator, pisCreator,
pisPureCreator, pisCosigner,
pisIrrelevant, pisIrrelevant,
runStakeRedeemerHandler, runStakeRedeemerHandler,
) where ) where
@ -51,6 +51,7 @@ import Agora.Proposal (
ResultTag, ResultTag,
) )
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Utils (pmapMaybe, ppureIf)
import Data.Tagged (Tagged) import Data.Tagged (Tagged)
import Generics.SOP qualified as SOP import Generics.SOP qualified as SOP
import Plutarch.Api.V1 (PCredential) import Plutarch.Api.V1 (PCredential)
@ -68,6 +69,8 @@ import Plutarch.Extra.IsData (
PlutusTypeDataList, PlutusTypeDataList,
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
import Plutarch.Extra.Sum (PSum (PSum)) import Plutarch.Extra.Sum (PSum (PSum))
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
@ -128,6 +131,7 @@ data ProposalLock
-- ^ The identifier of the proposal. -- ^ The identifier of the proposal.
ResultTag ResultTag
-- ^ The option which was voted on. This allows votes to be retracted. -- ^ The option which was voted on. This allows votes to be retracted.
| Cosigned ProposalId
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Show Show
@ -139,6 +143,7 @@ PlutusTx.makeIsDataIndexed
''ProposalLock ''ProposalLock
[ ('Created, 0) [ ('Created, 0)
, ('Voted, 1) , ('Voted, 1)
, ('Cosigned, 2)
] ]
{- | Haskell-level redeemer for Stake scripts. {- | Haskell-level redeemer for Stake scripts.
@ -292,8 +297,6 @@ data PStakeRedeemer (s :: S)
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
SOP.Generic
, -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
@ -337,6 +340,14 @@ data PProposalLock (s :: S)
] ]
) )
) )
| PCosigned
( Term
s
( PDataRecord
'[ "cosigned" ':= PProposalId
]
)
)
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
@ -403,7 +414,7 @@ pnumCreatedProposals =
{- | The role of a stake for a particular proposal. Scott-encoded. {- | The role of a stake for a particular proposal. Scott-encoded.
@since 0.2.0 @since 1.0.0
-} -}
data PStakeRole (s :: S) data PStakeRole (s :: S)
= -- | The stake was used to vote on the proposal. = -- | The stake was used to vote on the proposal.
@ -412,26 +423,24 @@ data PStakeRole (s :: S)
-- ^ The option which was voted for. -- ^ The option which was voted for.
| -- | The stake was used to create the proposal. | -- | The stake was used to create the proposal.
PCreator PCreator
| -- | The stake was used to both create and vote on the proposal. | -- | The stake was used to cosign the propsoal.
PBoth PCosigner
(Term s PResultTag)
-- ^ The option which was voted for.
| -- | The stake has nothing to do with the given proposal.
PIrrelevant
deriving stock deriving stock
( -- | @since 0.2.0 ( -- | @since 1.0.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.2.0 ( -- | @since 1.0.0
PlutusType PlutusType
, -- | @since 0.2.0
PEq
) )
-- | @since 1.0.0
instance DerivePlutusType PStakeRole where instance DerivePlutusType PStakeRole where
type DPTStrat _ = PlutusTypeScott type DPTStrat _ = PlutusTypeScott
-- | @since 1.0.0
type PStakeRoles = PList PStakeRole
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
{- | Who authorizes the transaction? {- | Who authorizes the transaction?
@ -603,114 +612,103 @@ data StakeRedeemerImpl = StakeRedeemerImpl
{- | Retutn true if the stake was used to voted on the proposal. {- | Retutn true if the stake was used to voted on the proposal.
@since 0.2.0 @since 1.0.0
-} -}
pisVoter :: forall (s :: S). Term s (PStakeRole :--> PBool) pisVoter :: forall (s :: S). Term s (PStakeRoles :--> PBool)
pisVoter = phoistAcyclic $ pisVoter =
plam $ \sr -> pmatch sr $ \case phoistAcyclic $
PVoter _ -> pconstant True pany
PBoth _ -> pconstant True #$ plam
_ -> pconstant False ( \r -> pmatch r $ \case
PVoter _ -> pconstant True
_ -> pconstant False
)
{- | Retutn true if the stake was used to create the proposal. {- | Retutn true if the stake was used to create the proposal.
@since 0.2.0 @since 1.0.0
-} -}
pisCreator :: forall (s :: S). Term s (PStakeRole :--> PBool) pisCreator :: forall (s :: S). Term s (PStakeRoles :--> PBool)
pisCreator = phoistAcyclic $ pisCreator =
plam $ \sr -> pmatch sr $ \case phoistAcyclic $
PCreator -> pconstant True pany
PBoth _ -> pconstant True #$ plam
_ -> pconstant False ( \r -> pmatch r $ \case
PCreator -> pconstant True
_ -> pconstant False
)
{- | Retutn true if the stake was used to create the proposal, but not vote on {- | Retutn true if the stake was used to cosign the proposal.
the proposal.
@since 0.2.0 @since 1.0.0
-} -}
pisPureCreator :: forall (s :: S). Term s (PStakeRole :--> PBool) pisCosigner :: forall (s :: S). Term s (PStakeRoles :--> PBool)
pisPureCreator = phoistAcyclic $ pisCosigner =
plam $ \sr -> pmatch sr $ \case phoistAcyclic $
PCreator -> pconstant True pany
_ -> pconstant False #$ plam
( \r -> pmatch r $ \case
PCosigner -> pconstant True
_ -> pconstant False
)
{- | Return true if the stake isn't related to the proposal. {- | Return true if the stake isn't related to the proposal.
@since 0.2.0 @since 1.0.0
-} -}
pisIrrelevant :: forall (s :: S). Term s (PStakeRole :--> PBool) pisIrrelevant :: forall (s :: S). Term s (PStakeRoles :--> PBool)
pisIrrelevant = phoistAcyclic $ pisIrrelevant = pnull
plam $ \sr -> pmatch sr $ \case
PIrrelevant -> pconstant True
_ -> pconstant False
{- | Get the role of a stake for the proposal specified by the poroposal id, {- | Get the role of a stake for the proposal specified by the poroposal id,
given the 'StakeDatum.lockedBy' field of the stake. given the 'StakeDatum.lockedBy' field of the stake.
Note that the list of locks is cosidered valid only if it contains at most @since 1.0.0
two locks from the given proposal: one voter lock and one creator lock.
@since 0.2.0
-} -}
pgetStakeRole :: pgetStakeRoles ::
forall (s :: S). forall (s :: S).
Term Term
s s
( PProposalId ( PProposalId
:--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock)
:--> PStakeRole :--> PStakeRoles
) )
pgetStakeRole = phoistAcyclic $ pgetStakeRoles = phoistAcyclic $
plam $ \pid locks -> plam $ \pid ->
pfoldl pmapMaybe
# plam # plam
( \role (pfromData -> lock) -> ( flip
let thisRole = pmatch lock $ \case pmatch
PCreated ((pfield @"created" #) -> pid') -> ( \case
pif PCreated ((pfield @"created" #) -> pid') ->
(pid' #== pid) ppureIf
(pcon PCreator) # (pid' #== pid)
(pcon PIrrelevant) # pcon PCreator
PVoted lock' -> pletAll lock' $ \lockF -> PVoted r -> pletAll r $ \rF ->
pif ppureIf
(lockF.votedOn #== pid) # (rF.votedOn #== pid)
(pcon $ PVoter lockF.votedFor) # pcon (PVoter rF.votedFor)
(pcon PIrrelevant) PCosigned ((pfield @"cosigned" #) -> pid') ->
in pcombineStakeRole # thisRole # role ppureIf
# (pid' #== pid)
# pcon PCosigner
)
. pfromData
) )
# pcon PIrrelevant
# locks
where
pcombineStakeRole ::
forall (s :: S).
Term
s
( PStakeRole
:--> PStakeRole
:--> PStakeRole
)
pcombineStakeRole = phoistAcyclic $
plam $ \x y ->
let cannotCombine = ptraceError "duplicate roles"
in pmatch x $ \case
PVoter r -> pmatch y $ \case
PCreator -> pcon $ PBoth r
PIrrelevant -> x
_ -> cannotCombine
PCreator -> pmatch y $ \case
PVoter r -> pcon $ PBoth r
PIrrelevant -> x
_ -> cannotCombine
PBoth _ -> cannotCombine
PIrrelevant -> y
{- | Get the outcome that was voted for. {- | Get the outcome that was voted for.
@since 0.2.0 @since 1.0.0
-} -}
pextractVoteOption :: forall (s :: S). Term s (PStakeRole :--> PResultTag) pextractVoteOption :: forall (s :: S). Term s (PStakeRoles :--> PResultTag)
pextractVoteOption = phoistAcyclic $ pextractVoteOption =
plam $ \sr -> pmatch sr $ \case phoistAcyclic $
PVoter r -> r plam $
PBoth r -> r (passertPJust # "not voter" #)
_ -> ptraceError "not voter" . ( pfindJust
# plam
( flip pmatch $ \case
PVoter r -> pjust # r
_ -> pnothing
)
#
)

112
agora/Agora/Stake/Redeemers.hs
View file

@ -16,7 +16,7 @@ module Agora.Stake.Redeemers (
import Agora.Proposal ( import Agora.Proposal (
PProposalId, PProposalId,
PProposalRedeemer (PUnlock, PVote), PProposalRedeemer (PCosign, PUnlock, PVote),
ProposalStatus (Finished), ProposalStatus (Finished),
) )
import Agora.Stake ( import Agora.Stake (
@ -25,7 +25,7 @@ import Agora.Stake (
PNoProposal, PNoProposal,
PSpendProposal PSpendProposal
), ),
PProposalLock (PCreated, PVoted), PProposalLock (PCosigned, PCreated, PVoted),
PSigContext (owner, signedBy), PSigContext (owner, signedBy),
PSignedBy ( PSignedBy (
PSignedByDelegate, PSignedByDelegate,
@ -187,35 +187,47 @@ paddNewLock = phoistAcyclic $
@since 1.0.0 @since 1.0.0
-} -}
ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
ppermitVote = phoistAcyclic $ ppermitVote = pvoteHelper #$ phoistAcyclic $
pvoteHelper #$ phoistAcyclic $ plam $ \ctx -> unTermCont $ do
plam $ \ctx -> unTermCont $ do ctxF <- pmatchC ctx
ctxF <- pmatchC ctx
let withOnlyOneStakeInput = withOnlyOneStakeInput <- pletC $
plam $ \lock -> unTermCont $ do plam $ \lock -> unTermCont $ do
pguardC "Only one stake input allowed" $ pguardC "Only one stake input allowed" $
pisSingleton # ctxF.stakeInputDatums pisSingleton # ctxF.stakeInputDatums
pure lock pure lock
pure $ pure $
paddNewLock #$ pmatch ctxF.proposalContext $ \case paddNewLock #$ pmatch ctxF.proposalContext $ \case
PSpendProposal pid _ r -> pmatch r $ \case PSpendProposal pid _ r -> pmatch r $ \case
PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) -> PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
mkRecordConstr mkRecordConstr
PVoted PVoted
( #votedOn .= pdata pid ( #votedOn .= pdata pid
.& #votedFor .= pdata voteFor .& #votedFor .= pdata voteFor
) )
_ -> ptraceError "Expected Vote" PCosign _ ->
PNewProposal pid ->
withOnlyOneStakeInput withOnlyOneStakeInput
#$ mkRecordConstr #$ mkRecordConstr
PCreated PCosigned
( #created .= pdata pid ( #cosigned .= pdata pid
) )
_ -> ptraceError "Expected proposal" _ -> ptraceError "Expected Vote"
PNewProposal pid ->
withOnlyOneStakeInput
#$ mkRecordConstr
PCreated
( #created .= pdata pid
)
_ -> ptraceError "Expected proposal"
data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
deriving stock (Generic)
deriving anyclass (PlutusType, PEq)
instance DerivePlutusType PRemoveLocksMode where
type DPTStrat _ = PlutusTypeScott
{- | Remove stake locks with the proposal id given the list of existing locks. {- | Remove stake locks with the proposal id given the list of existing locks.
The first parameter controls whether to revmove creator locks or not. The first parameter controls whether to revmove creator locks or not.
@ -225,36 +237,46 @@ premoveLocks ::
Term Term
s s
( PProposalId ( PProposalId
:--> PBool :--> PRemoveLocksMode
:--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock)
:--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock)
) )
premoveLocks = phoistAcyclic $ premoveLocks = phoistAcyclic $
plam $ \pid rc -> plam $ \pid rl -> unTermCont $ do
pfilter shouldRemoveOtherLocks <- pletC $
# plam plam $ \pid' ->
( \(pfromData -> l) -> pnot #$ pmatch l $ \case pid' #== pid #&& rl #== pcon PRemoveAllLocks
PCreated ((pfield @"created" #) -> pid') -> rc #&& pid' #== pid
PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid pure $
) pfilter
# plam
( \(pfromData -> l) -> pnot #$ pmatch l $ \case
PCosigned ((pfield @"cosigned" #) -> pid') ->
shouldRemoveOtherLocks # pid'
PCreated ((pfield @"created" #) -> pid') ->
shouldRemoveOtherLocks # pid'
PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid
)
{- | Default implementation of 'Agora.Stake.RetractVotes'. {- | Default implementation of 'Agora.Stake.RetractVotes'.
@since 1.0.0 @since 1.0.0
-} -}
pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
pretractVote = phoistAcyclic $ pretractVote = pvoteHelper #$ phoistAcyclic $
pvoteHelper #$ phoistAcyclic $ plam $
plam $ flip pmatch $ \ctxF ->
flip pmatch $ \ctxF -> pmatch ctxF.proposalContext $ \case
pmatch ctxF.proposalContext $ \case PSpendProposal pid s r -> pmatch r $ \case
PSpendProposal pid s r -> pmatch r $ \case PUnlock _ ->
PUnlock _ -> let mode =
let allowRemovingCreatorLock = pif
s #== pconstant Finished (s #== pconstant Finished)
in premoveLocks # pid # allowRemovingCreatorLock (pcon PRemoveAllLocks)
_ -> ptraceError "Expected unlock" (pcon PRemoveVoterLockOnly)
_ -> ptraceError "Expected spending proposal" in premoveLocks # pid # mode
_ -> ptraceError "Expected unlock"
_ -> ptraceError "Expected spending proposal"
-- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'. -- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
pdelegateHelper :: pdelegateHelper ::

86
agora/Agora/Utils.hs
View file

@ -27,11 +27,19 @@ module Agora.Utils (
pisSingleton, pisSingleton,
pfromSingleton, pfromSingleton,
pmapMaybe, pmapMaybe,
PAlternative (..),
ppureIf,
pltBy,
pinsertUniqueBy,
) where ) where
import Plutarch.Api.V1 (PPOSIXTime, PTokenName, PValidatorHash) import Plutarch.Api.V1 (PPOSIXTime, PTokenName, PValidatorHash)
import Plutarch.Api.V2 (PScriptHash) import Plutarch.Api.V2 (PScriptHash)
import Plutarch.Extra.Applicative (PApplicative (ppure))
import Plutarch.Extra.Category (PCategory (pidentity)) import Plutarch.Extra.Category (PCategory (pidentity))
import Plutarch.Extra.Functor (PFunctor (PSubcategory))
import Plutarch.Extra.Maybe (pnothing)
import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy)
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime)) import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
@ -284,3 +292,81 @@ pmapMaybe = phoistAcyclic $
# (self # t) # (self # t)
) )
(const pnil) (const pnil)
-- -- | @since 1.0.0
-- -- | @since 1.0.0
-- ppureIf'
infixl 3 #<|>
-- | @since 1.0.0
class (PApplicative f) => PAlternative (f :: PType -> PType) where
(#<|>) ::
forall (a :: PType) (s :: S).
(PSubcategory f a) =>
Term s (f a :--> f a :--> f a)
pempty ::
forall (a :: PType) (s :: S).
(PSubcategory f a) =>
Term s (f a)
-- | @since 1.0.0
instance PAlternative PMaybe where
(#<|>) = phoistAcyclic $
plam $ \a b -> pmatch a $ \case
PNothing -> b
PJust _ -> a
pempty = pnothing
-- | @since 1.0.0
ppureIf ::
forall
(f :: PType -> PType)
(a :: PType)
(s :: S).
(PAlternative f, PSubcategory f a) =>
Term s (PBool :--> a :--> f a)
ppureIf = phoistAcyclic $
plam $ \cond x ->
pif
cond
(ppure # x)
pempty
pltBy ::
forall (a :: PType) (s :: S).
Term
s
( PComparator a
:--> a
:--> a
:--> PBool
)
pltBy = phoistAcyclic $
plam $ \c x y ->
pcompareBy # c # x # y #== pcon PLT
-- | @since 1.0.0
pinsertUniqueBy ::
forall (list :: PType -> PType) (a :: PType) (s :: S).
(PIsListLike list a) =>
Term s (PComparator a :--> a :--> list a :--> list a)
pinsertUniqueBy = phoistAcyclic $
plam $ \c x ->
let lt = pltBy # c
eq = pequateBy # c
in precList
( \self h t ->
let ensureUniqueness =
pif
(eq # x # h)
(ptraceError "inserted value already exists")
next =
pif
(lt # x # h)
(pcons # x #$ pcons # h # t)
(pcons # h #$ self # t)
in ensureUniqueness next
)
(const $ psingleton # x)