Script manager

ytxp-plutarch/examples/script-manager/doc/README.md

@@ -0,0 +1,16 @@
+# Script manager
+
+This is a script manager example.
+
+## Components
+
+- [Script](components/script.md)
+
+## Transaction Families
+
+- [Script deploying](transaction-families/deploying.md)
+- [Script removing](transaction-families/removing.md)
+
+## Transaction Flows
+
+None.

ytxp-plutarch/examples/script-manager/doc/components/script.md

@@ -0,0 +1,41 @@
+# Script component
+
+This component holds the deployed script.
+
+## UTxO Specification
+
+The UTxO reflecting this component has the following attributes:
+
+### Address
+
+The component sits on the address of the YTxP yielding-validator of the protocol.
+
+### Value
+
+Undefined.
+
+### Datum
+
+The component must have a unit datum.
+
+### Reference Script
+
+The content is undefined, although it is expected to contain the deployed script.
+
+## States
+
+The Script component does not have meaningful states.
+
+## Participation in Transaction Families
+
+### Introduction
+
+- [Script deploying](../transaction-families/deploying.md)
+
+### Modification
+
+None.
+
+### Termination
+
+- [Script removing](../transaction-families/removing.md)

ytxp-plutarch/examples/script-manager/doc/transaction-families/deploying.md

@@ -0,0 +1,72 @@
+# Script Deploying Transaction Family
+
+This transaction family describes the deployment of a script.
+
+## Script Execution Specification
+
+### Transaction Family Parameters
+
+1. `yieldingValidatorAddress :: ScriptAddress`
+  The address locking yielding UTxOs
+
+2. `yieldingMPSymbol :: CurrencySymbol`
+  The currency symbol of the script component token
+
+3. `signatory :: PubKeyHash`
+  The signatory required to authorize the deployment
+
+### Script Purpose
+
+This script must fail on any script purpose except `Rewarding`.
+
+### Redeemer
+
+None.
+
+### Reference Inputs
+
+This transaction family does not check the reference inputs to determine whether the script is successful or not.
+
+However, the following reference inputs should be present to support the YTxP.
+
+1. Authorized Reference Script UTxO (1)
+This input must contain the transaction hash for the `AuthorisedScript` script representing this transaction family.
+
+### Inputs
+
+Undefined.
+
+### Redeemer Map
+
+Undefined.
+
+### Mints
+
+1. Script component token minting policy (1)
+
+Other mints may happen.
+
+### Outputs
+
+The outputs of this transaction family are
+
+1. Script (1)
+    - The Script component is created at the yielding validator script address with no staking address
+    - The Script component value has
+      - 1 Script component token
+    - The datum must:
+      - Must have a unit datum
+
+Other outputs are permitted.
+
+### Staking Events
+
+The withdrawal from this staking validator.
+
+### Validity Range
+
+Undefined.
+
+### Signatories
+
+The transaction must be signed by the signatory specified in the transaction family parameter.

ytxp-plutarch/examples/script-manager/doc/transaction-families/removing.md

@@ -0,0 +1,63 @@
+# Script Removing Transaction Family
+
+This transaction family describes the removal of a script.
+
+## Script Execution Specification
+
+### Transaction Family Parameters
+
+1. `yieldingMPSymbol :: CurrencySymbol`
+  The currency symbol of the script component token
+2. `signatory :: PubKeyHash`
+  The signatory required to authorize the deployment
+
+### Script Purpose
+
+This script must fail on any script purpose except `Rewarding`.
+
+### Redeemer
+
+None.
+
+### Reference Inputs
+
+This transaction family does not check the reference inputs to determine whether the script is successful or not.
+
+However, the follow reference inputs should be present to support the YTxP.
+
+1. Authorized Reference Script UTxO (1)
+This input must contain the transaction hash for the `AuthorisedScript` script representing this transaction family.
+
+### Inputs
+
+1. Script (1)
+    - The Script component value has
+      - 1 Script component token
+
+Other inputs may exist.
+
+### Redeemer Map
+
+Undefined.
+
+### Mints
+
+1. Script component token minting policy (-1)
+
+Other mints may happen.
+
+### Outputs
+
+Undefined.
+
+### Staking Events
+
+The withdrawal of this staking validator.
+
+### Validity Range
+
+Undefined.
+
+### Signatories
+
+The transaction must be signed by the signatory specified in the transaction family parameter.

ytxp-plutarch/examples/script-manager/src/Cardano/YTxP/Example/PUtils.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Cardano.YTxP.Example.PUtils (
+  pisRewarding,
+  ptraceDebugC,
+  tryGetComponentOutput,
+  tryGetComponentInput,
+) where
+
+import Plutarch.LedgerApi.V3 (
+  PAddress,
+  PCurrencySymbol,
+  PScriptInfo (PRewardingScript),
+  PTxInInfo,
+  PTxOut,
+  ptxInInfo'resolved,
+  ptxOut'address,
+  ptxOut'value,
+ )
+import Plutarch.LedgerApi.Value (pvalueOf)
+import PlutusLedgerApi.V3 (TokenName (TokenName))
+
+-- | Return False if script purpose is not rewarding
+pisRewarding :: Term s (PScriptInfo :--> PBool)
+pisRewarding = phoistAcyclic $ plam $ \purpose ->
+  pmatch purpose $ \case
+    PRewardingScript _ -> pcon PTrue
+    _other -> pcon PFalse
+
+-- | Like `ptraceDebug`, but works in a `TermCont` monad
+ptraceDebugC :: Term s PString -> TermCont s ()
+ptraceDebugC s = tcont $ \f -> ptraceInfo s (f ())
+
+-- | Find the first valid component output
+tryGetComponentOutput ::
+  Term s PCurrencySymbol ->
+  Term s PAddress ->
+  Term s (PBuiltinList (PAsData PTxOut)) ->
+  Term s (PAsData PTxOut)
+tryGetComponentOutput yieldingMPSymbol yieldingValidatorAddress outputs =
+  pmatch outputs $ \case
+    PCons componentOutput' rest -> unTermCont $ do
+      componentOutput <- pmatchC $ pfromData componentOutput'
+      return $
+        pif
+          ( ( pvalueOf
+                # pfromData (ptxOut'value componentOutput)
+                # yieldingMPSymbol
+                # pconstant (TokenName "")
+            )
+              #== pconstant 1
+              #&& yieldingValidatorAddress
+              #== ptxOut'address componentOutput
+          )
+          componentOutput'
+          ( pif
+              (rest #== pcon PNil)
+              ( ptraceInfoError
+                  "tryGetComponentOutput: Component not found"
+              )
+              (tryGetComponentOutput yieldingMPSymbol yieldingValidatorAddress rest)
+          )
+    _other -> ptraceInfoError "tryGetComponentOutput: Empty output list"
+
+-- | Find the first valid component input
+tryGetComponentInput ::
+  Term s PCurrencySymbol ->
+  Term s (PBuiltinList (PAsData PTxInInfo)) ->
+  Term s PTxOut
+tryGetComponentInput yieldingMPSymbol inputs =
+  pmatch inputs $ \case
+    PCons componentInInfo' rest -> unTermCont $ do
+      componentInInfo <- pmatchC $ pfromData componentInInfo'
+      resolved' <- pletC $ ptxInInfo'resolved componentInInfo
+      resolved <- pmatchC resolved'
+
+      return $
+        pif
+          ( ( pvalueOf
+                # pfromData (ptxOut'value resolved)
+                # yieldingMPSymbol
+                # pconstant (TokenName "")
+            )
+              #== pconstant 1
+          )
+          resolved'
+          ( pif
+              (rest #== pcon PNil)
+              ( ptraceInfoError
+                  "tryGetComponentInput: Component not found"
+              )
+              (tryGetComponentInput yieldingMPSymbol rest)
+          )
+    _other -> ptraceInfoError "tryGetComponentInput: Empty output list"

ytxp-plutarch/examples/script-manager/src/Cardano/YTxP/Example/Script/Deploying.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Cardano.YTxP.Example.Script.Deploying (
+  -- * TxF Params
+  Params,
+
+  -- * Script
+  deployingTxF,
+) where
+
+import Cardano.YTxP.Example.PUtils (
+  pisRewarding,
+  ptraceDebugC,
+  tryGetComponentOutput,
+ )
+import Control.Monad (void)
+import Plutarch.Builtin.Unit (punit)
+import Plutarch.LedgerApi.V3 (
+  PDatum (PDatum),
+  POutputDatum (POutputDatum),
+  PScriptContext (pscriptContext'scriptInfo),
+  pscriptContext'txInfo,
+  ptxInfo'mint,
+  ptxInfo'outputs,
+  ptxInfo'signatories,
+  ptxOut'datum,
+ )
+import Plutarch.LedgerApi.Value (pvalueOf)
+import PlutusLedgerApi.V3 (
+  Address (Address),
+  Credential (ScriptCredential),
+  CurrencySymbol,
+  PubKeyHash,
+  ScriptHash,
+  TokenName (TokenName),
+ )
+
+-- * Parameters
+
+-- | Parameters for the Deploying Transaction Family
+data Params = Params
+  { yieldingValidatorScriptHash :: !ScriptHash
+  , yieldingMPSymbol :: !CurrencySymbol
+  , signatory :: !PubKeyHash
+  }
+  deriving stock (Show)
+
+-- * Script
+
+{- | Deploying Transaction Family implemented as a YTxP YieldedTo Staking Validator.
+Refer to the transaction family specification (examples/script-manager/doc/transaction-families/deploying.md)
+for a complete description.
+-}
+deployingTxF :: Params -> Term s (PScriptContext :--> PUnit)
+deployingTxF params = phoistAcyclic $ plam $ \context' -> unTermCont $ do
+  -- ScriptContext extraction
+
+  ptraceDebugC "ScriptContext extraction"
+
+  context <- pmatchC context'
+
+  -- Ensures that this script is activated by the rewarding event
+  void $
+    pguardC "The current script is expected to be activated by a rewarding event" $
+      pisRewarding # pscriptContext'scriptInfo context
+
+  txInfo <- pmatchC $ pscriptContext'txInfo context
+
+  -- Deploying must be authorised by the signatory
+  pguardC "The transaction is expected to be signed by the signatory" $
+    pelem
+      # pdata (pconstant params.signatory)
+      # pfromData (ptxInfo'signatories txInfo)
+
+  -- The component token must be minted
+  pguardC "The component token is expected to be minted" $
+    pvalueOf
+      # pfromData (ptxInfo'mint txInfo)
+      # pconstant params.yieldingMPSymbol
+      # pconstant (TokenName "")
+      #== 1
+
+  -- Script output extraction
+
+  ptraceDebugC "Script output extraction"
+
+  scriptOutput <-
+    pmatchC $
+      pfromData $
+        tryGetComponentOutput
+          (pconstant params.yieldingMPSymbol)
+          ( pconstant . flip Address Nothing . ScriptCredential $
+              params.yieldingValidatorScriptHash
+          )
+          (pfromData $ ptxInfo'outputs txInfo)
+
+  pguardC "The component must have a unit datum" $
+    ptxOut'datum scriptOutput
+      #== pcon (POutputDatum $ pcon $ PDatum (pforgetData (pdata punit)))
+
+  pure punit