Add initDirectoryTx + test (failing in lib/SmartTokens/LinkedList/Com…

…mon.hs:214)

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)

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

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
 

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 :))
 

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

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)

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

src/test/Wst/Test/Env.hs

@@ -1,6 +1,7 @@
 {-| Running tests that use the 'BuildTxEv'
 -}
 module Wst.Test.Env(
+  admin,
   asAdmin
 ) where
 

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