diff --git a/src/lib/SmartTokens/LinkedList/MintDirectory.hs b/src/lib/SmartTokens/LinkedList/MintDirectory.hs index a3f1ae6..462bef9 100644 --- a/src/lib/SmartTokens/LinkedList/MintDirectory.hs +++ b/src/lib/SmartTokens/LinkedList/MintDirectory.hs @@ -1,10 +1,6 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -25,24 +21,25 @@ module SmartTokens.LinkedList.MintDirectory ( DirectoryNodeAction (..) ) where +import Data.Maybe (fromJust) import Generics.SOP qualified as SOP +import Plutarch.Core.Utils (pand'List, passert, phasUTxO) +import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields) import Plutarch.LedgerApi.V3 (PScriptContext, PTxOutRef) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutarch.Unsafe (punsafeCoerce) -import SmartTokens.LinkedList.Common (makeCommon, pInit, pInsert) - -import Plutarch.Core.Utils (pand'List, passert, phasUTxO) import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData, PByteString, PDataRecord, PEq, PIsData, PLabeledType ((:=)), PUnit, PlutusType, PlutusTypeData, S, Term, TermCont (runTermCont), pconstant, perror, pfield, pfromData, pif, plam, plet, pletFields, pmatch, pto, type (:-->), (#)) -import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) -import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields) -import qualified PlutusTx -import PlutusTx.Builtins.Internal qualified as BI +import Plutarch.Unsafe (punsafeCoerce) +import PlutusCore.Data qualified as PLC import PlutusLedgerApi.V3 (CurrencySymbol) +import PlutusTx qualified +import PlutusTx.Builtins.Internal qualified as BI +import SmartTokens.LinkedList.Common (makeCommon, pInit, pInsert) -------------------------------- -- FinSet Node Minting Policy: @@ -52,7 +49,23 @@ data DirectoryNodeAction | InsertDirectoryNode CurrencySymbol deriving stock (Show, Eq, Generic) deriving anyclass (SOP.Generic) - deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +PlutusTx.makeIsDataIndexed ''DirectoryNodeAction + [('InitDirectory, 0), ('InsertDirectoryNode, 1)] + +-- instance PlutusTx.ToData DirectoryNodeAction where +-- toBuiltinData = \case +-- InitDirectory -> BI.dataToBuiltinData $ PLC.Constr 0 [] +-- InsertDirectoryNode sym -> BI.dataToBuiltinData $ PLC.Constr 1 [PlutusTx.toData sym] + +-- instance PlutusTx.FromData DirectoryNodeAction where +-- fromBuiltinData (BI.builtinDataToData -> d) = case d of +-- PLC.Constr 0 [] -> Just InitDirectory +-- PLC.Constr 1 [PlutusTx.fromData -> Just currencySymbol] -> Just (InsertDirectoryNode currencySymbol) +-- _ -> Nothing + +-- instance PlutusTx.UnsafeFromData DirectoryNodeAction where +-- unsafeFromBuiltinData = fromJust . PlutusTx.fromBuiltinData deriving via (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction) diff --git a/src/lib/SmartTokens/Types/Constants.hs b/src/lib/SmartTokens/Types/Constants.hs index a61e88f..a551404 100644 --- a/src/lib/SmartTokens/Types/Constants.hs +++ b/src/lib/SmartTokens/Types/Constants.hs @@ -2,21 +2,32 @@ module SmartTokens.Types.Constants( protocolParamsToken, pprotocolParamsToken, - pprotocolParamsTokenData + pprotocolParamsTokenData, + + -- * Directory node token name + directoryNodeToken, + pdirectoryNodeToken, + pdirectoryNodeTokenData ) where import Plutarch.LedgerApi.V1 (PTokenName (..)) -import Plutarch.Prelude - ( PAsData, pconstantData, ClosedTerm, pconstant ) -import PlutusLedgerApi.V1 (TokenName(..)) +import Plutarch.Prelude (ClosedTerm, PAsData, pconstant, pconstantData) +import PlutusLedgerApi.V1 (TokenName (..)) protocolParamsToken :: TokenName protocolParamsToken = "ProtocolParams" -pprotocolParamsToken :: ClosedTerm PTokenName +pprotocolParamsToken :: ClosedTerm PTokenName pprotocolParamsToken = pconstant protocolParamsToken pprotocolParamsTokenData :: ClosedTerm (PAsData PTokenName) pprotocolParamsTokenData = pconstantData protocolParamsToken +directoryNodeToken :: TokenName +directoryNodeToken = "" + +pdirectoryNodeToken :: ClosedTerm PTokenName +pdirectoryNodeToken = pconstant directoryNodeToken +pdirectoryNodeTokenData :: ClosedTerm (PAsData PTokenName) +pdirectoryNodeTokenData = pconstantData directoryNodeToken diff --git a/src/lib/SmartTokens/Types/PTokenDirectory.hs b/src/lib/SmartTokens/Types/PTokenDirectory.hs index a0f6392..9453afa 100644 --- a/src/lib/SmartTokens/Types/PTokenDirectory.hs +++ b/src/lib/SmartTokens/Types/PTokenDirectory.hs @@ -24,36 +24,28 @@ module SmartTokens.Types.PTokenDirectory ( BlacklistNode(..), ) where +import Data.Text qualified as T import Generics.SOP qualified as SOP -import Plutarch ( Config(NoTracing), Config(NoTracing) ) -import Plutarch.Builtin - ( pasByteStr, - pasConstr, - pasList, - pforgetData, - plistData, - pforgetData, - plistData ) +import GHC.Stack (HasCallStack) +import Plutarch (Config (NoTracing)) +import Plutarch.Builtin (pasByteStr, pasConstr, pasList, pforgetData, plistData) import Plutarch.Core.PlutusDataList (DerivePConstantViaDataList (..), PlutusTypeDataList, ProductIsData (..)) import Plutarch.Core.Utils (pcond, pheadSingleton, pmkBuiltinList) import Plutarch.DataRepr (PDataFields) +import Plutarch.DataRepr.Internal import Plutarch.DataRepr.Internal.Field (HRec (..), Labeled (Labeled)) import Plutarch.Evaluate (unsafeEvalTerm) +import Plutarch.Internal qualified as PI +import Plutarch.Internal.Other (printScript) import Plutarch.LedgerApi.V3 (PCredential, PCurrencySymbol) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.List import Plutarch.Prelude import Plutarch.Unsafe (punsafeCoerce) -import PlutusLedgerApi.V3 - ( Credential, CurrencySymbol, BuiltinByteString ) +import PlutusLedgerApi.V3 (BuiltinByteString, Credential, CurrencySymbol) import PlutusTx (Data (B, Constr)) import PlutusTx qualified -import Plutarch.DataRepr.Internal -import GHC.Stack (HasCallStack) -import Plutarch.Internal.Other (printScript) -import qualified Data.Text as T -import qualified Plutarch.Internal as PI @@ -101,7 +93,7 @@ instance PUnsafeLiftDecl PBlacklistNode where -- the same string. -- -- >>> _printTerm NoTracing $ unsafeEvalTerm NoTracing (pconstant $ BlacklistNode { blnKey = "a hi", blnNext = "a" }) --- "program 1.0.0 (List [B #61206869, B #61])" +-- "program 1.0.0 (List [B #61206869, B #60])" _printTerm :: HasCallStack => Config -> ClosedTerm a -> String _printTerm config term = printScript $ either (error . T.unpack) id $ PI.compile config term diff --git a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs index 7ae6814..2f8f764 100644 --- a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs +++ b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -7,6 +6,8 @@ module Wst.Offchain.BuildTx.DirectorySet ( initDirectorySet, insertDirectoryNode, + -- * Values + initialNode ) where import Cardano.Api qualified as C @@ -21,25 +22,24 @@ import Convex.Utils qualified as Utils import GHC.Exts (IsList (..)) import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..), TokenName (..)) import SmartTokens.LinkedList.MintDirectory (DirectoryNodeAction (..)) +import SmartTokens.Types.Constants (directoryNodeToken) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) import Wst.Offchain.Scripts (directoryNodeMintingScript, directoryNodeSpendingScript, scriptPolicyIdV3) --- TODO: Where should this go -directoryNodeToken :: C.AssetName -directoryNodeToken = unTransAssetName $ TokenName "DirectoryNodeNFT" +initialNode :: DirectorySetNode +initialNode = DirectorySetNode (CurrencySymbol "") (CurrencySymbol "") (PubKeyCredential "") (PubKeyCredential "") initDirectorySet :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PolicyId -> C.TxIn -> m () initDirectorySet paramsPolicyId txIn = Utils.inBabbage @era $ do netId <- queryNetworkId - let mintingScript = directoryNodeMintingScript txIn - mintPlutus mintingScript InitDirectory directoryNodeToken 1 + mintPlutus mintingScript InitDirectory (unTransAssetName directoryNodeToken) 1 let val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra - $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) directoryNodeToken, 1)] + $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) (unTransAssetName directoryNodeToken), 1)] addr = C.makeShelleyAddressInEra @@ -48,9 +48,9 @@ initDirectorySet paramsPolicyId txIn = Utils.inBabbage @era $ do (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId) C.NoStakeAddress - d = DirectorySetNode (CurrencySymbol "") (CurrencySymbol "") (PubKeyCredential "") (PubKeyCredential "") - dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData d + dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData initialNode + output :: C.TxOut C.CtxTx era output = C.TxOut addr val dat C.ReferenceScriptNone addBtx (over L.txOuts (output :)) @@ -70,7 +70,7 @@ insertDirectoryNode paramsPolicyId initialTxIn (_, firstTxOut) (newKey, transfer _ -> error "insertDirectoryNode: invalid output" newVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra - $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) directoryNodeToken, 1)] + $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) (unTransAssetName directoryNodeToken), 1)] addr = C.makeShelleyAddressInEra @@ -92,7 +92,7 @@ insertDirectoryNode paramsPolicyId initialTxIn (_, firstTxOut) (newKey, transfer firstDat = firstTxData { next = newKey} firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData firstDat) C.ReferenceScriptNone - mintPlutus directoryMintingScript (InsertDirectoryNode newKey) directoryNodeToken 1 + mintPlutus directoryMintingScript (InsertDirectoryNode newKey) (unTransAssetName directoryNodeToken) 1 addBtx (over L.txOuts (newOutput :)) addBtx (over L.txOuts (firstOutput :)) diff --git a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs index f1e47af..61740f4 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Wst.Offchain.BuildTx.ProtocolParams ( mintProtocolParams, getProtocolParamsGlobalInline @@ -22,14 +20,18 @@ import Wst.Offchain.Scripts (protocolParamsMintingScript, protocolParamsTokenC :: C.AssetName protocolParamsTokenC = unTransAssetName protocolParamsToken +{-| Mint the protocol parameters NFT. Returns NFT's policy ID. +-} mintProtocolParams :: forall era m. (C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => ProgrammableLogicGlobalParams -> C.TxIn -> m () mintProtocolParams params txIn = Utils.inBabbage @era $ do netId <- queryNetworkId let mintingScript = protocolParamsMintingScript txIn + policyId = scriptPolicyIdV3 mintingScript + val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra - $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) protocolParamsTokenC, 1)] + $ fromList [(C.AssetId policyId protocolParamsTokenC, 1)] addr = C.makeShelleyAddressInEra diff --git a/src/lib/Wst/Offchain/Endpoints/DirectorySet.hs b/src/lib/Wst/Offchain/Endpoints/DirectorySet.hs new file mode 100644 index 0000000..b9a6038 --- /dev/null +++ b/src/lib/Wst/Offchain/Endpoints/DirectorySet.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-| Endpoints for managing and initializing the policy directory +-} +module Wst.Offchain.Endpoints.DirectorySet( + initDirectoryTx +) where + +import Cardano.Api (PlutusScript, PlutusScriptV3) +import Cardano.Api.Shelley qualified as C +import Control.Monad.Except (MonadError) +import Control.Monad.Reader (MonadReader) +import Convex.Class (MonadBlockchain) +import Convex.CoinSelection qualified +import Convex.PlutusLedger.V1 (transCredential, transPolicyId) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) +import Wst.Offchain.BuildTx.DirectorySet (initDirectorySet) +import Wst.Offchain.BuildTx.ProtocolParams (mintProtocolParams) +import Wst.Offchain.Endpoints.Env (BuildTxEnv, BuildTxError) +import Wst.Offchain.Endpoints.Env qualified as Env +import Wst.Offchain.Scripts (directoryNodeMintingScript, + programmableLogicBaseScript, + programmableLogicGlobalScript, + protocolParamsMintingScript, scriptPolicyIdV3) + +data DeploymentScripts = + DeploymentScripts + { dsTxIn :: C.TxIn -- ^ The 'txIn' that we spend when deploying the protocol params and directory set + , dsDirectoryMintingScript :: PlutusScript PlutusScriptV3 + , dsProtocolParamsMintingScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicBaseScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 + } + +deploymentScripts :: C.TxIn -> DeploymentScripts +deploymentScripts dsTxIn = + let dsDirectoryMintingScript = directoryNodeMintingScript dsTxIn + dsProtocolParamsMintingScript = protocolParamsMintingScript dsTxIn + dsProgrammableLogicBaseScript = programmableLogicBaseScript (programmableLogicStakeCredential result) -- Parameterized by the stake cred of the global script + dsProgrammableLogicGlobalScript = programmableLogicGlobalScript (directoryNodePolicyId result) -- Parameterized by the CS holding protocol params datum + result = DeploymentScripts + { dsTxIn + , dsDirectoryMintingScript + , dsProtocolParamsMintingScript + , dsProgrammableLogicBaseScript + , dsProgrammableLogicGlobalScript + } + in result + +programmableLogicStakeCredential :: DeploymentScripts -> C.StakeCredential +programmableLogicStakeCredential = + C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicGlobalScript + +programmableLogicBaseCredential :: DeploymentScripts -> C.PaymentCredential +programmableLogicBaseCredential = + C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript + +directoryNodePolicyId :: DeploymentScripts -> C.PolicyId +directoryNodePolicyId = scriptPolicyIdV3 . dsDirectoryMintingScript + +protocolParamsPolicyId :: DeploymentScripts -> C.PolicyId +protocolParamsPolicyId = scriptPolicyIdV3 . dsProtocolParamsMintingScript + +globalParams :: DeploymentScripts -> ProgrammableLogicGlobalParams +globalParams scripts = + ProgrammableLogicGlobalParams + { directoryNodeCS = transPolicyId (directoryNodePolicyId scripts) + , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script + } + +{-| Build a transaction that initialises the directory. Returns the +transaction and the 'TxIn' that was selected for the one-shot NFTs. +-} +initDirectoryTx :: (MonadReader (BuildTxEnv era) m, MonadBlockchain era m, MonadError (BuildTxError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era, C.TxIn) +initDirectoryTx = do + (txi, _) <- Env.selectOperatorOutput + let scripts = deploymentScripts txi + (tx, _) <- Env.balanceTxEnv $ do + mintProtocolParams (globalParams scripts) txi + initDirectorySet (protocolParamsPolicyId scripts) txi + pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi) diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs index 2a98ae3..7f3fdc6 100644 --- a/src/lib/Wst/Offchain/Scripts.hs +++ b/src/lib/Wst/Offchain/Scripts.hs @@ -59,7 +59,7 @@ protocolParamsSpendingScript = -- symbol uniqueness across instances directoryNodeMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 directoryNodeMintingScript txIn = - let script = tryCompile prodConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) + let script = tryCompile tracingConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) in C.PlutusScriptSerialised $ serialiseScript script -- | The spending script for the directory node tokens, parameterized by the diff --git a/src/test/Wst/Test/Env.hs b/src/test/Wst/Test/Env.hs index 7570b81..f4142ec 100644 --- a/src/test/Wst/Test/Env.hs +++ b/src/test/Wst/Test/Env.hs @@ -1,6 +1,7 @@ {-| Running tests that use the 'BuildTxEv' -} module Wst.Test.Env( + admin, asAdmin ) where diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index 34b35c1..f253824 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -4,19 +4,23 @@ module Wst.Test.UnitTest( ) where import Cardano.Api qualified as C -import Convex.Class (MonadBlockchain, MonadUtxoQuery) +import Control.Monad (void) +import Convex.Class (MonadBlockchain (sendTx), MonadUtxoQuery) import Convex.MockChain.Utils (mockchainSucceeds) import Convex.Utils (failOnError) +import Convex.Wallet.Operator (signTxOperator) import PlutusLedgerApi.V1.Credential (Credential (..)) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Wst.Offchain.Endpoints.DirectorySet qualified as Endpoints import Wst.Offchain.Endpoints.ProtocolParams qualified as Endpoints -import Wst.Test.Env (asAdmin) +import Wst.Test.Env (admin, asAdmin) tests :: TestTree tests = testGroup "unit tests" [ testCase "deploy protocol params" (mockchainSucceeds deployProtocolParams) + , testCase "deploy directory set" (mockchainSucceeds deployDirectorySet) ] deployProtocolParams :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m () @@ -26,5 +30,9 @@ deployProtocolParams = failOnError $ asAdmin @C.ConwayEra $ do { directoryNodeCS = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" , progLogicCred = ScriptCredential "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" } - _ <- Endpoints.deployParamsTx params - pure () + Endpoints.deployParamsTx params >>= void . sendTx . signTxOperator admin + +deployDirectorySet :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m () +deployDirectorySet = failOnError $ asAdmin @C.ConwayEra $ do + (tx, _txI) <- Endpoints.initDirectoryTx + void $ sendTx $ signTxOperator admin tx diff --git a/src/wst-poc.cabal b/src/wst-poc.cabal index 43f4a42..16eb8fa 100644 --- a/src/wst-poc.cabal +++ b/src/wst-poc.cabal @@ -74,6 +74,7 @@ library Wst.Offchain.BuildTx.LinkedList Wst.Offchain.BuildTx.ProgrammableLogic Wst.Offchain.BuildTx.ProtocolParams + Wst.Offchain.Endpoints.DirectorySet Wst.Offchain.Endpoints.Env Wst.Offchain.Endpoints.ProtocolParams Wst.Offchain.Scripts