From eceb1f5c56aeeed74e437f80afcf3e4ebb8810c7 Mon Sep 17 00:00:00 2001 From: Amir Rad Date: Thu, 19 Dec 2024 12:20:59 +0000 Subject: [PATCH] Seizing tx builder --- .../Contracts/ProgrammableLogicBase.hs | 48 +++++- .../SmartTokens/LinkedList/MintDirectory.hs | 9 +- .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 155 ++++++++++++++---- 3 files changed, 172 insertions(+), 40 deletions(-) diff --git a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs index e6ac804..1114895 100644 --- a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs +++ b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs @@ -6,9 +6,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE UndecidableInstances #-} + module SmartTokens.Contracts.ProgrammableLogicBase ( + TokenProof (..), + ProgrammableLogicGlobalRedeemer (..), mkProgrammableLogicBase, - mkProgrammableLogicGlobal + mkProgrammableLogicGlobal, ) where import Plutarch.Builtin (pasByteStr, pasConstr, pforgetData) @@ -40,6 +44,9 @@ import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V1.Value (Value) import SmartTokens.Types.ProtocolParams (PProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (PDirectorySetNode) +import qualified PlutusTx +import Plutarch.DataRepr (DerivePConstantViaData (..)) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) -- | Strip Ada from a ledger value -- Importantly this function assumes that the Value is provided by the ledger (i.e. via the ScriptContext) @@ -56,6 +63,17 @@ pstripAda = phoistAcyclic $ -- The current implementation of the contracts in this module are not designed to be maximally efficient. -- In the future, this should be optimized to use the redeemer indexing design pattern to identify and validate -- the programmable inputs. +data TokenProof + = TokenExists Integer + | TokenDoesNotExist Integer + deriving stock (Show, Eq, Generic) + deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +deriving via + (DerivePConstantViaData TokenProof PTokenProof) + instance + (PConstantDecl TokenProof) + data PTokenProof (s :: S) = PTokenExists @@ -74,6 +92,9 @@ data PTokenProof (s :: S) instance DerivePlutusType PTokenProof where type DPTStrat _ = PlutusTypeData +instance PUnsafeLiftDecl PTokenProof where + type PLifted PTokenProof = TokenProof + emptyValue :: Value emptyValue = mempty @@ -279,9 +300,23 @@ pcheckTransferLogicAndGetProgrammableValue = plam $ \directoryNodeCS refInputs p -- drop the ada entry in the value before traversing the rest of the value entries in go # proofList # (ptail # mapInnerList) # pto (pto pemptyLedgerValue) --- type ProgrammableLogicGlobalRedeemer = PBuiltinList (PAsData PTokenProof) -data ProgrammableLogicGlobalRedeemer (s :: S) +data ProgrammableLogicGlobalRedeemer + = TransferAct [TokenProof] + | SeizeAct { + plgrSeizeInputIdx :: Integer, + plgrSeizeOutputIdx :: Integer, + plgrDirectoryNodeIdx :: Integer + } + deriving (Show, Eq, Generic) + deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +deriving via + (DerivePConstantViaData ProgrammableLogicGlobalRedeemer PProgrammableLogicGlobalRedeemer) + instance + (PConstantDecl ProgrammableLogicGlobalRedeemer) + +data PProgrammableLogicGlobalRedeemer (s :: S) = PTransferAct ( Term s ( PDataRecord '[ "proofs" ':= PBuiltinList (PAsData PTokenProof) ] ) ) | PSeizeAct @@ -297,14 +332,17 @@ data ProgrammableLogicGlobalRedeemer (s :: S) deriving stock (Generic) deriving anyclass (PlutusType, PIsData, PEq) -instance DerivePlutusType ProgrammableLogicGlobalRedeemer where +instance DerivePlutusType PProgrammableLogicGlobalRedeemer where type DPTStrat _ = PlutusTypeData +instance PUnsafeLiftDecl PProgrammableLogicGlobalRedeemer where + type PLifted PProgrammableLogicGlobalRedeemer = ProgrammableLogicGlobalRedeemer + mkProgrammableLogicGlobal :: ClosedTerm (PAsData PCurrencySymbol :--> PScriptContext :--> PUnit) mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do ctxF <- pletFields @'["txInfo", "redeemer", "scriptInfo"] ctx infoF <- pletFields @'["inputs", "referenceInputs", "outputs", "signatories", "wdrl"] ctxF.txInfo - let red = pfromData $ punsafeCoerce @_ @_ @(PAsData ProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer) + let red = pfromData $ punsafeCoerce @_ @_ @(PAsData PProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer) referenceInputs <- plet $ pfromData infoF.referenceInputs -- Extract protocol parameter UTxO ptraceInfo "Extracting protocol parameter UTxO" diff --git a/src/lib/SmartTokens/LinkedList/MintDirectory.hs b/src/lib/SmartTokens/LinkedList/MintDirectory.hs index b1fcd39..a3f1ae6 100644 --- a/src/lib/SmartTokens/LinkedList/MintDirectory.hs +++ b/src/lib/SmartTokens/LinkedList/MintDirectory.hs @@ -54,6 +54,11 @@ data DirectoryNodeAction deriving anyclass (SOP.Generic) deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) +deriving via + (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction) + instance + (PConstantDecl DirectoryNodeAction) + data PDirectoryNodeAction (s :: S) = PInit (Term s (PDataRecord '[])) | PInsert (Term s (PDataRecord '["keyToInsert" ':= PByteString])) @@ -65,10 +70,6 @@ instance PUnsafeLiftDecl PDirectoryNodeAction where instance DerivePlutusType PDirectoryNodeAction where type DPTStrat _ = PlutusTypeData -deriving via - (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction) - instance - (PConstantDecl DirectoryNodeAction) mkDirectoryNodeMP :: ClosedTerm diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index 658a97a..b62b75d 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -4,7 +4,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant if" #-} {-# HLINT ignore "Use second" #-} module Wst.Offchain.BuildTx.ProgrammableLogic ( issueProgrammableToken, @@ -15,21 +14,24 @@ where import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C -import Convex.BuildTx (MonadBuildTx, addReference, - addWithdrawZeroPlutusV2InTransaction, addWithdrawal, +import Control.Lens (over, (^.)) +import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addWithdrawalWithTxBody, buildScriptWitness, - findIndexReference, mintPlutus, spendPlutusInlineDatum) + findIndexReference, findIndexSpending, mintPlutus, + spendPlutusInlineDatum) +import Convex.CardanoApi.Lenses as L import Convex.Class (MonadBlockchain (queryNetworkId)) import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential, unTransPolicyId) import Convex.Scripts (fromHashableScriptData) import Convex.Utils qualified as Utils -import Data.Bifunctor (Bifunctor (second)) import Data.Foldable (find, maximumBy) import Data.Function (on) import Data.Maybe (fromJust) -import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..)) +import PlutusLedgerApi.V3 (CurrencySymbol (..)) import SmartTokens.Contracts.Issuance (SmartTokenMintingAction (MintPToken, RegisterPToken)) +import SmartTokens.Contracts.ProgrammableLogicBase (ProgrammableLogicGlobalRedeemer (..), + TokenProof (..)) import SmartTokens.Types.ProtocolParams import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode) @@ -38,12 +40,15 @@ import Wst.Offchain.Scripts (programmableLogicBaseScript, programmableLogicGlobalScript, programmableLogicMintingScript) --- Takes care of both registrations and token mints -issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> (C.PolicyId, C.TxOut C.CtxTx era) -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)]-> m CurrencySymbol -issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do - netId <- queryNetworkId - ProgrammableLogicGlobalParams{directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut) +{- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific + minting logic stake script witness is included in the final transaction. + - If the programmable token is not in the directory, then it is registered + - If the programmable token is in the directory, then it is minted +-} +issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> (C.PolicyId, C.TxOut C.CtxTx era) -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)] -> m CurrencySymbol +issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do + ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut) progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS @@ -62,29 +67,37 @@ issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q mintPlutus mintingScript MintPToken an q else mintPlutus mintingScript RegisterPToken an q - >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic) + >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic) pure policyId -transferProgrammableToken :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> (C.TxIn, C.PolicyId) -> C.TxIn -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m () -transferProgrammableToken nid paramsTxIn tokenTxIn programmableTokenSymbol [] = error "directory list empty" -transferProgrammableToken nid (paramsTxIn, paramsPolId) tokenTxIn programmableTokenSymbol directoryList = do +{- User facing transfer of programmable tokens from one address to another. + The caller should ensure that the specific transfer logic stake script + witness is included in the final transaction. + + NOTE: If the token is not in the directory, then the function will + use a PDoesNotExist redeemer to prove that the token is not programmable + + IMPORTANT: The caller should ensure that the destination address of the + programmable token(s) in this transaction all correspond to the same + programmable logic payment credential (even in the case of non-programmable + tokens) otherwise the transaction will fail onchain validation. +-} +transferProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => (C.TxIn, C.PolicyId) -> C.TxIn -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m () +transferProgrammableToken _ _ _ [] = error "directory list not initialised" +transferProgrammableToken (paramsTxIn, paramsPolId) tokenTxIn programmableTokenSymbol directoryList = Utils.inBabbage @era $ do + nid <- queryNetworkId - let globalStakeScript = programmableLogicGlobalScript paramsPolId + let globalStakeScript = programmableLogicGlobalScript paramsPolId globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript baseSpendingScript = programmableLogicBaseScript globalStakeCred - addReference paramsTxIn - spendPlutusInlineDatum tokenTxIn baseSpendingScript () - - -- Finds the directory node with the highest key that is less than or equal - -- to the programmable token symbol - let (dirNodeRef, dirNodeOut) = + -- Finds the directory node with the highest key that is less than or equal + -- to the programmable token symbol + (dirNodeRef, dirNodeOut) = maximumBy (compare `on` (fmap key . getDirectoryNodeInline . snd)) $ filter (maybe False ((<= programmableTokenSymbol) . key) . getDirectoryNodeInline . snd) directoryList - addReference dirNodeRef - let -- Finds the index of the directory node reference in the transaction ref -- inputs directoryNodeReferenceIndex txBody = @@ -94,18 +107,98 @@ transferProgrammableToken nid (paramsTxIn, paramsPolId) tokenTxIn programmableTo -- exists with the programmable token symbol programmableLogicGlobalRedeemer txBody = if fmap key (getDirectoryNodeInline dirNodeOut) == Just programmableTokenSymbol - then directoryNodeReferenceIndex txBody -- TODO: wrap in PTokenExists - else directoryNodeReferenceIndex txBody -- TODO: wrap in PTokenNotExists + -- TODO: extend to allow multiple proofs, onchain allows it + then TransferAct [TokenExists $ directoryNodeReferenceIndex txBody] + else TransferAct [TokenDoesNotExist $ directoryNodeReferenceIndex txBody] + + programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody) + + addReference paramsTxIn -- Protocol Params TxIn + addReference dirNodeRef -- Directory Node TxIn + spendPlutusInlineDatum tokenTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase + addWithdrawalWithTxBody -- Add the global script witness to the transaction + (C.makeStakeAddress nid globalStakeCred) + (C.Quantity 0) + $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness + +{- Seize a programmable token from a user address to an issuer address. The + outputs address will be that of the issuer retrieved from @issuerTxOut@. + Throws if the payment credentials of the issuer output does not match the + programmable logic payment credential. + + IMPORTANT: It is the caller's responsibility to + ensure that the specific issuer logic stake script witness is included in the + final transaction. +-} +seizePragrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => (C.TxIn, C.PolicyId) -> (C.TxIn, C.TxOut C.CtxTx era) -> (C.TxIn, C.TxOut C.CtxTx era) -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m () +seizePragrammableToken (paramsTxIn, paramsPolId) (seizingTxIn, seizingOutput) (issuerTxIn, issuerTxOut) seizingTokenSymbol directoryList = Utils.inBabbage @era $ do + nid <- queryNetworkId + + let globalStakeScript = programmableLogicGlobalScript paramsPolId + globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript + baseSpendingScript = programmableLogicBaseScript globalStakeCred + + -- Finds the directory node entry that references the programmable token symbol + dirNodeRef <- + maybe (error "Cannot seize non-programmable token. Entry does not exist in directoryList") (pure . fst) $ + find (isNodeWithProgrammableSymbol seizingTokenSymbol) directoryList + + seizingTokenPolicyId <- either (error . show) pure $ unTransPolicyId seizingTokenSymbol + + checkIssuerAddressIsProgLogicCred (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 baseSpendingScript) issuerTxOut + + let seizedValue = case seizingOutput of + (C.TxOut _ v _ _) -> + C.filterValue + ( \case + C.AdaAssetId -> True + C.AssetId a _ -> a == seizingTokenPolicyId + ) + $ C.txOutValueToValue v + + (issuerOutAddr, issuerOutVal) = case issuerTxOut of + (C.TxOut a (C.txOutValueToValue -> v) _ _) -> + (a, C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra (v <> seizedValue)) + + seizedIssuerOutput = C.TxOut issuerOutAddr issuerOutVal C.TxOutDatumNone C.ReferenceScriptNone + + -- Finds the index of the directory node reference in the transaction ref + -- inputs + directoryNodeReferenceIndex txBody = + fromIntegral @Int @Integer $ findIndexReference dirNodeRef txBody + + -- Finds the index of the issuer input in the transaction body + issuerInputIndex txBody = + fromIntegral @Int @Integer $ findIndexSpending issuerTxIn txBody + + -- Finds the index of the issuer seized output in the transaction body + issueOutputIndex txBody = + fromIntegral @Int @Integer $ fst $ fromJust (find ((== seizedIssuerOutput) . snd) $ zip [0 ..] $ txBody ^. L.txOuts) + + -- The seizing redeemer for the global script + programmableLogicGlobalRedeemer txBody = + SeizeAct + { plgrSeizeInputIdx = issuerInputIndex txBody, + plgrSeizeOutputIdx = issueOutputIndex txBody, + plgrDirectoryNodeIdx = directoryNodeReferenceIndex txBody + } programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody) - addWithdrawalWithTxBody + addReference paramsTxIn -- Protocol Params TxIn + addReference dirNodeRef -- Directory Node TxIn + spendPlutusInlineDatum seizingTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase + addBtx (over L.txOuts (seizedIssuerOutput :)) -- Add the seized output to the transaction + addWithdrawalWithTxBody -- Add the global script witness to the transaction (C.makeStakeAddress nid globalStakeCred) (C.Quantity 0) $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness -seizePragrammableToken :: (MonadBuildTx C.ConwayEra m) => m () -seizePragrammableToken = pure () + -- TODO: check that the issuerTxOut is at a programmable logic payment credential +checkIssuerAddressIsProgLogicCred :: forall era m. ( MonadBuildTx era m) => C.PaymentCredential -> C.TxOut C.CtxTx era -> m () +checkIssuerAddressIsProgLogicCred _progLogicCred (C.TxOut (C.AddressInEra _ (C.ShelleyAddress _ _pcred _stakeRef)) _ _ C.ReferenceScriptNone) = + pure () +checkIssuerAddressIsProgLogicCred _ _ = error "Issuer address is not a programmable logic credential" isNodeWithProgrammableSymbol :: CurrencySymbol -> (C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx)) -> Bool isNodeWithProgrammableSymbol programmableTokenSymbol (_, dn) = @@ -114,8 +207,8 @@ isNodeWithProgrammableSymbol programmableTokenSymbol (_, dn) = _ -> False getDirectoryNodeInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe DirectorySetNode -getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ d _)) = - case d of +getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) = + case dat of C.TxOutDatumInline C.BabbageEraOnwardsConway (fromHashableScriptData -> Just d) -> Just d _ -> Nothing getDirectoryNodeInline _ = Nothing