standalone stake redeemers

agora/Agora/Stake.hs

@@ -19,6 +19,16 @@ module Agora.Stake (
   PProposalLock (..),
   PStakeRole (..),
 
+  -- * Validation context
+  PStakeInputContext (..),
+  PStakeOutputContext (..),
+  PSigContext (..),
+  PStakeRedeemerContext (..),
+  PStakeRedeemerHandlerContext (..),
+  PProposalContext (..),
+  PStakeRedeemerHandler,
+  StakeRedeemerImpl (..),
+
   -- * Utility functions
   pstakeLocked,
   pnumCreatedProposals,
@@ -30,17 +40,22 @@ module Agora.Stake (
   pisIrrelevant,
 ) where
 
-import Agora.Proposal (PProposalId, PResultTag, ProposalId, ResultTag)
+import Agora.Proposal (PProposalId, PProposalRedeemer, PResultTag, ProposalId, ResultTag)
 import Agora.SafeMoney (GTTag)
 import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (PCredential)
+import Plutarch.Api.V1 (KeyGuarantees (Sorted), PCredential)
+import Plutarch.Api.V1.Value (PValue)
 import Plutarch.Api.V2 (
+  AmountGuarantees (Positive),
   PMaybeData,
+  PTxInfo,
  )
 import Plutarch.DataRepr (
   DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
  )
+import Plutarch.Extra.AssetClass (PAssetClass)
 import Plutarch.Extra.Field (pletAll)
 import Plutarch.Extra.IsData (
   DerivePConstantViaDataList (DerivePConstantViaDataList),
@@ -231,6 +246,8 @@ newtype PStakeDatum (s :: S) = PStakeDatum
       PIsData
     , -- | @since 0.1.0
       PEq
+    , -- | @since 1.0.0
+      PDataFields
     )
 
 instance DerivePlutusType PStakeDatum where
@@ -408,6 +425,185 @@ data PStakeRole (s :: S)
 instance DerivePlutusType PStakeRole where
   type DPTStrat _ = PlutusTypeScott
 
+--------------------------------------------------------------------------------
+
+{- | Represent the stake being spent.
+
+     @since 1.0.0
+-}
+data PStakeInputContext (s :: S) = PStakeInput
+  { ownInputDatum :: Term s PStakeDatum
+  -- ^ The stake datum of said stake.
+  , ownInputValue :: Term s (PValue 'Sorted 'Positive)
+  -- ^ The value carried by the stake UTxO.
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeInputContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Where the stake will go?
+
+     @since 1.0.0
+-}
+data PStakeOutputContext (s :: S)
+  = -- | The output stake is owned by the stake validator.
+    PStakeOutput
+      { ownOutputDatum :: Term s PStakeDatum
+      -- ^ The stake datum of the output stake.
+      , ownOutputValue :: Term s (PValue 'Sorted 'Positive)
+      -- ^ The value carried by the stake output UTxO.
+      }
+  | -- | The stake is burnt in the transaction.
+    PStakeBurnt
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeOutputContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Who authorizes the transaction?
+
+     @since 1.0.0
+-}
+data PSigContext (s :: S)
+  = -- | The stake owner authorized the transaction.
+    PSignedByOwner
+  | -- | The delegate authorized the transaction.
+    PSignedByDelegate
+  | -- | Both owner and delegate didn't authorize.
+    PUnknownSig
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PSigContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | The metadata carried by the stake redeemer. See also 'StakeRedeemer'.
+
+     @since 1.0.0
+-}
+data PStakeRedeemerContext (s :: S)
+  = -- | See also 'DepositWithdraw'.
+    PDepositWithdrawDelta (Term s (PDiscrete GTTag))
+  | -- | See also 'DelegateTo'.
+    PSetDelegateTo (Term s PCredential)
+  | PNoMetadata
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeRedeemerContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | The usage of proposal in the transaction.
+
+     @since 1.0.0
+-}
+data PProposalContext (s :: S)
+  = -- | A proposal is spent.
+    PWithProposalRedeemer (Term s PProposalRedeemer)
+  | -- | A new proposal is created.
+    PNewProposal
+  | -- | No proposal is spent or created.
+    PNoProposal
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PProposalContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | Context required in order for redeemer handlers to peform validation.
+
+     @1.0.0
+-}
+data PStakeRedeemerHandlerContext (s :: S) = PStakeRedeemerHandlerContext
+  { stakeInput :: Term s PStakeInputContext
+  , stakeOutput :: Term s PStakeOutputContext
+  , redeemerContext :: Term s PStakeRedeemerContext
+  , sigContext :: Term s PSigContext
+  , proposalContext :: Term s PProposalContext
+  , gtAssetClass :: Term s PAssetClass
+  , extraTxContext :: Term s PTxInfo
+  }
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PStakeRedeemerHandlerContext where
+  type DPTStrat _ = PlutusTypeScott
+
+{- | The plutarch type signature of the redeemer handlers.
+
+     A redeemer handler is a piece of validation logic that performs a unique
+      set of checks for its corresponding stake redeemer.
+
+     @since 1.0.0
+-}
+type PStakeRedeemerHandler = PStakeRedeemerHandlerContext :--> PUnit
+
+{- | A collection of stake redeemer handlers for each stake redeemers.
+
+     @since 1.0.0
+-}
+data StakeRedeemerImpl = StakeRedeemerImpl
+  { onDepositWithdraw :: ClosedTerm PStakeRedeemerHandler
+  -- ^ Handler for 'DepositWithdraw'.
+  , onDestroy :: ClosedTerm PStakeRedeemerHandler
+  -- ^ Handler for 'Destroy'.
+  , onPermitVote :: ClosedTerm PStakeRedeemerHandler
+  -- ^ Handler for 'permitVotes'.
+  , onRetractVote :: ClosedTerm PStakeRedeemerHandler
+  -- ^ Handler for 'RetractVotes'.
+  , onDelegateTo :: ClosedTerm PStakeRedeemerHandler
+  -- ^ Handler for 'DelegateTo'.
+  , onClearDelegate :: ClosedTerm PStakeRedeemerHandler
+  -- ^ handler for 'ClearDelegate'.
+  }
+
+--------------------------------------------------------------------------------
+
 {- | Retutn true if the stake was used to voted on the proposal.
 
      @since 0.2.0

agora/Agora/Stake/Redeemers.hs

@@ -0,0 +1,303 @@
+{- |
+Module     : Agora.Stake.Redeemers
+Maintainer : connor@mlabs.city
+Description: Default implementation of stake redeemer handlers
+
+Default implementation of stake redeemer handlers.
+-}
+module Agora.Stake.Redeemers (
+  ppermitVote,
+  pretractVote,
+  pdelegateTo,
+  pclearDelegate,
+  pdestroy,
+  pdepositWithdraw,
+) where
+
+import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
+import Agora.Stake (
+  PProposalContext (PNewProposal, PWithProposalRedeemer),
+  PSigContext (PSignedByOwner, PUnknownSig),
+  PStakeDatum (PStakeDatum),
+  PStakeInputContext (PStakeInput),
+  PStakeOutputContext (PStakeBurnt, PStakeOutput),
+  PStakeRedeemerContext (PDepositWithdrawDelta, PNoMetadata, PSetDelegateTo),
+  PStakeRedeemerHandler,
+  PStakeRedeemerHandlerContext (..),
+  pstakeLocked,
+ )
+import Plutarch.Api.V1.Address (PCredential)
+import Plutarch.Api.V1.Value (AmountGuarantees (Positive), PValue)
+import Plutarch.Api.V2 (PMaybeData)
+import Plutarch.Extra.Field (pletAllC)
+import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
+import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
+import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
+import Plutarch.Extra.Value (pgeqByClass, pgeqByClass')
+import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
+import Plutarch.SafeMoney (pdiscreteValue)
+import PlutusLedgerApi.V1.Value (AssetClass (..))
+import Prelude hiding (Num ((+)))
+
+-- | Return true if stake input and output carries the same value.
+pownOutputValueUnchanged ::
+  forall (s :: S).
+  Term s (PStakeRedeemerHandlerContext :--> PBool)
+pownOutputValueUnchanged = phoistAcyclic $
+  plam $
+    flip pmatch $ \ctxF -> unTermCont $ do
+      PStakeInput _ inVal <- pmatchC ctxF.stakeInput
+      PStakeOutput _ outVal <- pmatchC ctxF.stakeOutput
+
+      pure $ inVal #== outVal
+
+-- | Return true if only the @lockedBy@ field of the stake datum is updated.
+ponlyLocksUpdated ::
+  forall (s :: S).
+  Term s (PStakeRedeemerHandlerContext :--> PBool)
+ponlyLocksUpdated = phoistAcyclic $
+  plam $
+    flip pmatch $ \ctxF -> unTermCont $ do
+      PStakeInput inDat _ <- pmatchC ctxF.stakeInput
+      PStakeOutput outDat _ <- pmatchC ctxF.stakeOutput
+
+      inDatF <- pletAllC inDat
+
+      let onlyLocksUpdated =
+            let templateStakeDatum =
+                  mkRecordConstr
+                    PStakeDatum
+                    ( #stakedAmount .= inDatF.stakedAmount
+                        .& #owner .= inDatF.owner
+                        .& #delegatedTo .= inDatF.delegatedTo
+                        .& #lockedBy .= pfield @"lockedBy" # outDat
+                    )
+             in outDat #== templateStakeDatum
+
+      pure onlyLocksUpdated
+
+-- | Return true if the transaction is signed by the owner of the stake.
+psignedByOwner ::
+  forall (s :: S).
+  Term s (PStakeRedeemerHandlerContext :--> PBool)
+psignedByOwner = phoistAcyclic $
+  plam $
+    flip pmatch $ \ctxF -> pmatch ctxF.sigContext $ \case
+      PSignedByOwner -> pconstant True
+      _ -> pconstant False
+
+-- | Validation logic shared between 'ppermitVote' and 'retractVote'.
+pvoteHelper ::
+  forall (s :: S).
+  Term
+    s
+    ( (PProposalContext :--> PBool)
+        :--> PStakeRedeemerHandler
+    )
+pvoteHelper = phoistAcyclic $
+  plam $ \valProposalCtx ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    pguardC "Owner or delegate signs this transaction" $
+      pmatch ctxF.sigContext $ \case
+        PUnknownSig -> pconstant False
+        _ -> pconstant True
+
+    -- This puts trust into the Proposal. The Proposal must necessarily check
+    -- that this is not abused.
+
+    pguardC "Proposal ST spent" $
+      valProposalCtx # ctxF.proposalContext
+
+    pguardC "A UTXO must exist with the correct output" $
+      let valueCorrect = pownOutputValueUnchanged # ctx
+          outputDatumCorrect = ponlyLocksUpdated # ctx
+       in foldl1
+            (#&&)
+            [ ptraceIfFalse "valueCorrect" valueCorrect
+            , ptraceIfFalse "datumCorrect" outputDatumCorrect
+            ]
+
+    pure $ pconstant ()
+
+{- | Default implementation of 'Agora.Stake.PermitVote'.
+
+     @since 1.0.0
+-}
+ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
+ppermitVote = pvoteHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PWithProposalRedeemer r -> pmatch r $ \case
+        PVote _ -> pconstant True
+        _ -> ptrace "Expected Vote" $ pconstant False
+      PNewProposal -> pconstant True
+      _ -> pconstant False
+
+{- | Default implementation of 'Agora.Stake.RetractVotes'.
+
+     @since 1.0.0
+-}
+pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
+pretractVote = pvoteHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PWithProposalRedeemer r -> pmatch r $ \case
+        PUnlock _ -> pconstant True
+        _ -> ptrace "Expected Unlock" $ pconstant False
+      _ -> pconstant False
+
+-- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
+pdelegateHelper ::
+  forall (s :: S).
+  Term
+    s
+    ( (PStakeRedeemerContext :--> PMaybeData (PAsData PCredential))
+        :--> PStakeRedeemerHandler
+    )
+pdelegateHelper = phoistAcyclic $
+  plam $ \f ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    pguardC "Owner signs this transaction" $ psignedByOwner # ctx
+
+    PStakeInput inpDat _ <- pmatchC ctxF.stakeInput
+    PStakeOutput outDat _ <- pmatchC ctxF.stakeOutput
+
+    inpDatF <- pletAllC inpDat
+
+    let maybePkh = f # ctxF.redeemerContext
+
+    pguardC "Cannot delegate to the owner" $
+      pmaybeData
+        # pcon PTrue
+        # plam (\pkh -> pnot #$ inpDatF.owner #== pkh)
+        # maybePkh
+
+    pguardC "A UTXO must exist with the correct output" $
+      let correctOutputDatum =
+            outDat
+              #== mkRecordConstr
+                PStakeDatum
+                ( #stakedAmount .= inpDatF.stakedAmount
+                    .& #owner .= inpDatF.owner
+                    .& #delegatedTo .= pdata maybePkh
+                    .& #lockedBy .= inpDatF.lockedBy
+                )
+          valueCorrect = pownOutputValueUnchanged # ctx
+       in foldl1
+            (#&&)
+            [ ptraceIfFalse "valueCorrect" valueCorrect
+            , ptraceIfFalse "datumCorrect" correctOutputDatum
+            ]
+
+    pure $ pconstant ()
+
+{- | Default implementation of 'Agora.Stake.DelegateTo'.
+
+     @since 1.0.0
+-}
+pdelegateTo :: forall (s :: S). Term s PStakeRedeemerHandler
+pdelegateTo = pdelegateHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PSetDelegateTo c -> pdjust # pdata c
+      _ -> perror
+
+{- | Default implementation of 'Agora.Stake.ClearDelegate'.
+
+     @since 1.0.0
+-}
+pclearDelegate :: forall (s :: S). Term s PStakeRedeemerHandler
+pclearDelegate = pdelegateHelper #$ phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PNoMetadata -> pdnothing
+      _ -> perror
+
+{- | Default implementation of 'Agora.Stake.Destroy'.
+
+     @since 1.0.0
+-}
+pdestroy :: forall (s :: S). Term s PStakeRedeemerHandler
+pdestroy = phoistAcyclic $
+  plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    PStakeInput inpDat _ <- pmatchC ctxF.stakeInput
+    PStakeBurnt <- pmatchC ctxF.stakeOutput
+
+    pguardC "Owner signs this transaction" $
+      psignedByOwner # ctx
+
+    pguardC "Stake unlocked" $ pnot #$ pstakeLocked # inpDat
+
+    pure $ pconstant ()
+
+{- | Default implementation of 'Agora.Stake.DepositWithdraw'.
+
+     @since 1.0.0
+-}
+pdepositWithdraw :: forall (s :: S). Term s PStakeRedeemerHandler
+pdepositWithdraw = phoistAcyclic $
+  plam $ \ctx -> unTermCont $ do
+    ctxF <- pmatchC ctx
+
+    PStakeInput inpDat inpVal <- pmatchC ctxF.stakeInput
+    PStakeOutput outDat outVal <- pmatchC ctxF.stakeOutput
+
+    pguardC "Stake unlocked" $ pnot #$ pstakeLocked # inpDat
+
+    pguardC "Owner signs this transaction" $ psignedByOwner # ctx
+
+    pguardC
+      "A UTXO must exist with the correct output"
+      $ unTermCont $ do
+        inpDatF <- pletAllC inpDat
+        PDepositWithdrawDelta delta <- pmatchC ctxF.redeemerContext
+
+        let oldStakedAmount = pfromData $ inpDatF.stakedAmount
+
+        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 .= inpDatF.owner
+                    .& #delegatedTo .= inpDatF.delegatedTo
+                    .& #lockedBy .= inpDatF.lockedBy
+                )
+            datumCorrect = outDat #== expectedDatum
+
+        let valueDelta :: Term _ (PValue _ 'Positive)
+            valueDelta = pdiscreteValue # ctxF.gtAssetClass # delta
+
+            expectedValue =
+              inpVal <> valueDelta
+
+        gtAssetClassF <- pletAllC ctxF.gtAssetClass
+
+        let valueCorrect =
+              foldr1
+                (#&&)
+                [ pgeqByClass' (AssetClass ("", ""))
+                    # outVal
+                    # expectedValue
+                , pgeqByClass
+                    # gtAssetClassF.currencySymbol
+                    # gtAssetClassF.tokenName
+                    # outVal
+                    # expectedValue
+                ]
+        --
+        pure $
+          foldl1
+            (#&&)
+            [ ptraceIfFalse "valueCorrect" valueCorrect
+            , ptraceIfFalse "datumCorrect" datumCorrect
+            ]
+    pure $ pconstant ()

agora/Agora/Stake/Scripts.hs

@@ -5,28 +5,76 @@ Description: Plutus Scripts for Stakes.
 
 Plutus Scripts for Stakes.
 -}
-module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
+module Agora.Stake.Scripts (
+  stakePolicy,
+  stakeValidator,
+  mkStakeValidator,
+) where
 
 import Agora.Credential (authorizationContext, pauthorizedBy)
-import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
+import Agora.Proposal (PProposalRedeemer)
 import Agora.SafeMoney (GTTag)
-import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
+import Agora.Scripts (
+  AgoraScripts,
+  proposalSTAssetClass,
+  stakeSTSymbol,
+ )
 import Agora.Stake (
-  PStakeDatum (PStakeDatum),
-  PStakeRedeemer (..),
+  PProposalContext (
+    PNewProposal,
+    PNoProposal,
+    PWithProposalRedeemer
+  ),
+  PSigContext (
+    PSignedByDelegate,
+    PSignedByOwner,
+    PUnknownSig
+  ),
+  PStakeDatum,
+  PStakeInputContext (PStakeInput),
+  PStakeOutputContext (PStakeBurnt, PStakeOutput),
+  PStakeRedeemer (
+    PClearDelegate,
+    PDelegateTo,
+    PDepositWithdraw,
+    PDestroy,
+    PPermitVote,
+    PRetractVotes
+  ),
+  PStakeRedeemerContext (
+    PDepositWithdrawDelta,
+    PNoMetadata,
+    PSetDelegateTo
+  ),
+  PStakeRedeemerHandlerContext (
+    PStakeRedeemerHandlerContext
+  ),
+  StakeRedeemerImpl (
+    StakeRedeemerImpl,
+    onClearDelegate,
+    onDelegateTo,
+    onDepositWithdraw,
+    onDestroy,
+    onPermitVote,
+    onRetractVote
+  ),
   pstakeLocked,
  )
-import Data.Tagged (Tagged, untag)
+import Agora.Stake.Redeemers (
+  pclearDelegate,
+  pdelegateTo,
+  pdepositWithdraw,
+  pdestroy,
+  ppermitVote,
+  pretractVote,
+ )
+import Data.Tagged (Tagged (Tagged))
 import Plutarch.Api.V1 (
   PCredential (PPubKeyCredential, PScriptCredential),
   PTokenName,
-  PValue,
  )
 import Plutarch.Api.V1.AssocMap (plookup)
 import Plutarch.Api.V2 (
-  AmountGuarantees (Positive),
-  KeyGuarantees (Sorted),
-  PMaybeData,
   PMintingPolicy,
   PScriptPurpose (PMinting, PSpending),
   PTxInInfo,
@@ -41,17 +89,14 @@ import Plutarch.Extra.AssetClass (
  )
 import Plutarch.Extra.Bind (PBind ((#>>=)))
 import Plutarch.Extra.Field (pletAllC)
-import Plutarch.Extra.Functor (PFunctor (pfmap))
 import Plutarch.Extra.List (pfirstJust)
 import Plutarch.Extra.Maybe (
   passertPJust,
-  pdjust,
-  pdnothing,
   pjust,
+  pmaybe,
   pmaybeData,
   pnothing,
  )
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
   pfindTxInByTxOutRef,
   pfromOutputDatum,
@@ -65,21 +110,14 @@ import Plutarch.Extra.TermCont (
   ptryFromC,
  )
 import Plutarch.Extra.Value (
-  pgeqByClass',
-  pgeqBySymbol,
   psymbolValueOf,
  )
-import Plutarch.Numeric.Additive (
-  AdditiveMonoid (zero),
-  AdditiveSemigroup ((+)),
- )
 import Plutarch.SafeMoney (
-  pdiscreteValue',
   pvalueDiscrete',
  )
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
-import Prelude hiding (Num (..))
+import Prelude hiding (Num ((+)))
 
 {- | Policy for Stake state threads.
 
@@ -197,29 +235,246 @@ stakePolicy gtClassRef =
 
 --------------------------------------------------------------------------------
 
-{- | Validation context for stake redeemers that allow only one stake to be
-      spent in the transaction.
+{- | Create a stake validator, given the implementation of stake redeemers.
 
      @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
-    )
+mkStakeValidator ::
+  StakeRedeemerImpl ->
+  AgoraScripts ->
+  Tagged GTTag AssetClass ->
+  ClosedTerm PValidator
+mkStakeValidator
+  impl
+  as
+  (Tagged (AssetClass (gtSym, gtTn))) =
+    plam $ \datum redeemer ctx -> unTermCont $ do
+      gtAssetClass <- pletC $ passetClass # pconstant gtSym # pconstant gtTn
 
--- | @since 1.0.0
-instance DerivePlutusType POnlyOneStakeContext where
-  type DPTStrat _ = PlutusTypeScott
+      --------------------------------------------------------------------------
+
+      ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
+      txInfo <- pletC $ pfromData ctxF.txInfo
+      txInfoF <-
+        pletFieldsC
+          @'[ "inputs"
+            , "referenceInputs"
+            , "outputs"
+            , "mint"
+            , "validRange"
+            , "signatories"
+            , "redeemers"
+            , "datums"
+            ]
+          txInfo
+
+      --------------------------------------------------------------------------
+
+      -- Assemble the stake input context.
+
+      stakeInputDatum <- pfromData . fst <$> ptryFromC datum
+      stakeInputDatumF <- pletAllC $ pto stakeInputDatum
+
+      PSpending stakeInputRef <- pmatchC $ pfromData ctxF.purpose
+
+      -- The UTxO we are validating, which is also the input stake.
+      stakeInput <-
+        pletC $
+          pfield @"resolved"
+            #$ passertPJust # "Malformed script context: own input not found"
+            #$ pfindTxInByTxOutRef
+              # (pfield @"_0" # stakeInputRef)
+              # txInfoF.inputs
+
+      stakeInputF <- pletFieldsC @'["address", "value"] stakeInput
+
+      stakeInputContext <-
+        pletC $
+          pcon $
+            PStakeInput
+              stakeInputDatum
+              stakeInputF.value
+
+      --------------------------------------------------------------------------
+
+      -- Assemble the signature context.
+
+      signedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
+
+      let ownerSignsTransaction = signedBy # stakeInputDatumF.owner
+
+          delegateSignsTransaction =
+            pmaybeData
+              # pconstant False
+              # plam ((signedBy #) . pfromData)
+              # pfromData stakeInputDatumF.delegatedTo
+
+      sigContext <-
+        pletC $
+          pif ownerSignsTransaction (pcon PSignedByOwner) $
+            pif delegateSignsTransaction (pcon PSignedByDelegate) $
+              pcon PUnknownSig
+
+      --------------------------------------------------------------------------
+
+      stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as
+      mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
+      valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
+      spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
+
+      -- The stake validator can only handle one stake in one transaction.
+
+      pguardC "ST at inputs must be 1" $
+        spentST #== 1
+
+      let oneStakeBurnt =
+            ptraceIfFalse "Exactly one stake st burnt" $
+              mintedST #== (-1)
+
+      --------------------------------------------------------------------------
+
+      -- Assemble the stake output context.
+
+      let -- Look for the output stake.
+          stakeOutput =
+            pfirstJust
+              # plam
+                ( \output -> unTermCont $ do
+                    outputF <-
+                      pletFieldsC @'["address", "value", "datum"]
+                        output
+
+                    let isStakeOutput =
+                          -- The stake should be owned by the stake validator.
+                          outputF.address #== stakeInputF.address
+                            #&&
+                            -- The stake UTxO carries the state thread token.
+                            psymbolValueOf
+                              # stCurrencySymbol
+                              # outputF.value #== 1
+
+                        stakeOutputDatum =
+                          pfromOutputDatum
+                            # outputF.datum
+                            # txInfoF.datums
+
+                        context =
+                          pcon $
+                            PStakeOutput
+                              (pfromData stakeOutputDatum)
+                              outputF.value
+
+                    pure $
+                      pif
+                        isStakeOutput
+                        (pjust # context)
+                        pnothing
+                )
+              # pfromData txInfoF.outputs
+
+      stakeOutputContext <-
+        pletC $
+          pmatch stakeOutput $ \case
+            -- Stake output found.
+            PJust stakeOutput' -> stakeOutput'
+            -- Stake output not found, meaning the input stake should be burnt.
+            PNothing -> unTermCont $ do
+              pguardC "One stake should be burnt" oneStakeBurnt
+
+              pure $ pcon PStakeBurnt
+
+      --------------------------------------------------------------------------
+
+      -- Assemble the proposal context.
+
+      let AssetClass (propCs, propTn) = proposalSTAssetClass as
+
+      proposalSTClass <-
+        pletC $
+          passetClass
+            # pconstant propCs
+            # pconstant propTn
+
+      let pstMinted =
+            passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
+
+      proposalContext <-
+        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 pif pstMinted (pcon PNewProposal) $
+                pmaybe
+                  # pcon PNoProposal
+                  # plam
+                    ( \((convertRedeemer #) -> proposalRedeemer) ->
+                        pcon $ PWithProposalRedeemer proposalRedeemer
+                    )
+                  #$ proposalRef #>>= findRedeemer
+
+      --------------------------------------------------------------------------
+
+      -- Assemeble the redeemer handler context.
+
+      mkRedeemerhandlerContext <- pletC $
+        plam $ \redeemerContext ->
+          pcon $
+            PStakeRedeemerHandlerContext
+              stakeInputContext
+              stakeOutputContext
+              redeemerContext
+              sigContext
+              proposalContext
+              gtAssetClass
+              txInfo
+
+      noMetadataContext <-
+        pletC $
+          mkRedeemerhandlerContext
+            #$ pcon
+            $ PNoMetadata
+
+      --------------------------------------------------------------------------
+
+      -- Call the redeemer handler.
+
+      stakeRedeemer :: Term _ PStakeRedeemer <- fst <$> ptryFromC redeemer
+
+      pure $
+        popaque $
+          pmatch stakeRedeemer $ \case
+            PDestroy _ -> onDestroy impl # noMetadataContext
+            PPermitVote _ -> onPermitVote impl # noMetadataContext
+            PRetractVotes _ -> onRetractVote impl # noMetadataContext
+            PClearDelegate _ -> onClearDelegate impl # noMetadataContext
+            PDelegateTo ((pfield @"pkh" #) -> pkh) ->
+              onDelegateTo impl #$ mkRedeemerhandlerContext
+                #$ pcon
+                $ PSetDelegateTo pkh
+            PDepositWithdraw ((pfield @"delta" #) -> delta) ->
+              onDepositWithdraw impl #$ mkRedeemerhandlerContext
+                #$ pcon
+                $ PDepositWithdrawDelta delta
 
 {- | Validator intended for Stake UTXOs to be locked by.
 
@@ -261,16 +516,6 @@ instance DerivePlutusType POnlyOneStakeContext where
      - The stake must not be locked.
      - Tx must be signed by the owner.
 
-     === 'WitnessStake'
-
-     Allow this Stake to be included in a transaction without making
-     any changes to it. In the future,
-     this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
-
-     - Tx must be signed by the owner __or__ a proposal ST token must be spent
-       alongside the stake.
-     - The datum and value must remain unchanged.
-
      @since 0.1.0
 -}
 stakeValidator ::
@@ -279,328 +524,13 @@ stakeValidator ::
   -- | See 'Agora.Governor.Governor.gtClassRef'.
   Tagged GTTag AssetClass ->
   ClosedTerm PValidator
-stakeValidator as gtClassRef =
-  plam $ \datum redeemer ctx' -> unTermCont $ do
-    ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-    txInfo <- pletC $ pfromData ctx.txInfo
-    txInfoF <-
-      pletFieldsC
-        @'[ "mint"
-          , "inputs"
-          , "outputs"
-          , "signatories"
-          , "datums"
-          , "redeemers"
-          ]
-        txInfo
-
-    stakeRedeemer <- fst <$> ptryFromC redeemer
-
-    stakeDatum' <- pfromData . fst <$> ptryFromC datum
-    stakeDatum <- pletAllC $ pto stakeDatum'
-
-    PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
-
-    PJust ((pfield @"resolved" #) -> resolved) <-
-      pmatchC $
-        pfindTxInByTxOutRef
-          # (pfield @"_0" # txOutRef)
-          # txInfoF.inputs
-    resolvedF <- pletFieldsC @'["address", "value", "datumHash"] resolved
-
-    -- Whether the owner signs this transaction or not.
-    signedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
-
-    ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
-
-    delegateSignsTransaction <-
-      pletC $
-        pmaybeData
-          # pconstant False
-          # plam ((signedBy #) . pfromData)
-          # pfromData stakeDatum.delegatedTo
-
-    stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as
-    mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
-    valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
-    spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
-
-    -- Is the stake currently locked?
-    stakeIsLocked <- pletC $ pstakeLocked # stakeDatum'
-
-    pure $
-      pmatch stakeRedeemer $ \case
-        PDestroy _ -> unTermCont $ do
-          pguardC "ST at inputs must be 1" $
-            spentST #== 1
-
-          pguardC "Should burn ST" $
-            mintedST #== -1
-
-          pguardC "Stake unlocked" $ pnot # stakeIsLocked
-
-          pguardC "Owner signs this transaction" ownerSignsTransaction
-
-          pure $ popaque (pconstant ())
-        ------------------------------------------------------------------------
-        -- Handle redeemers that require own stake output.
-
-        _ -> unTermCont $ do
-          let AssetClass (propCs, propTn) = proposalSTAssetClass as
-              proposalSTClass = passetClass # pconstant propCs # pconstant propTn
-
-          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 <-
-            pletC $
-              pfilter
-                # plam
-                  ( \output -> unTermCont $ do
-                      outputF <- pletFieldsC @'["address", "value"] output
-
-                      pure $
-                        outputF.address #== resolvedF.address
-                          #&& psymbolValueOf # stCurrencySymbol # outputF.value #== 1
-                  )
-                # pfromData txInfoF.outputs
-
-          ----------------------------------------------------------------------
-
-          withSingleStake' ::
-            Term
-              s
-              ( (POnlyOneStakeContext :--> PUnit)
-                  :--> POpaque
-              ) <-
-            pletC $
-              plam $ \validationLogic -> unTermCont $ do
-                pguardC "ST at inputs must be 1" $
-                  spentST #== 1
-
-                ownOutput <- pletC $ phead # ownOutputs
-
-                let ownOutputDatum =
-                      pfromData $
-                        pfromOutputDatum @(PAsData PStakeDatum)
-                          # (pfield @"datum" # ownOutput)
-                          # txInfoF.datums
-
-                    ownOutputValue =
-                      pfield @"value" # ownOutput
-
-                    ownOutputValueUnchanged =
-                      pdata resolvedF.value #== pdata ownOutputValue
-
-                    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 .= pdata maybePkh
-                                .& #lockedBy .= stakeDatum.lockedBy
-                            )
-                      valueCorrect = ctx.ownOutputValueUnchanged
-                   in foldl1
-                        (#&&)
-                        [ ptraceIfFalse "valueCorrect" valueCorrect
-                        , ptraceIfFalse "datumCorrect" correctOutputDatum
-                        ]
-
-          pure $
-            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"
+stakeValidator =
+  mkStakeValidator $
+    StakeRedeemerImpl
+      { onDepositWithdraw = pdepositWithdraw
+      , onDestroy = pdestroy
+      , onPermitVote = ppermitVote
+      , onRetractVote = pretractVote
+      , onDelegateTo = pdelegateTo
+      , onClearDelegate = pclearDelegate
+      }