Programmable token issue tx builder

src/lib/SmartTokens/Contracts/Issuance.hs

@@ -1,19 +1,31 @@
-{-# LANGUAGE QualifiedDo #-}
 {-# LANGUAGE OverloadedRecordDot  #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE QualifiedDo          #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module SmartTokens.Contracts.Issuance (
   mkProgrammableLogicMinting,
+  SmartTokenMintingAction (..),
 ) where
 
-import Plutarch.LedgerApi.V3 (PCredential, PScriptContext, PScriptInfo(PMintingScript))
+import Plutarch.Builtin (pdataImpl, pfromDataImpl)
+import Plutarch.Core.Utils (pand'List, pheadSingleton, ptryLookupValue,
+                            pvalidateConditions, (#>))
+import Plutarch.Internal.PlutusType (PlutusType (pcon', pmatch'))
+import Plutarch.LedgerApi.V3 (PCredential, PScriptContext,
+                              PScriptInfo (PMintingScript))
+import Plutarch.LedgerApi.Value (PCurrencySymbol, pvalueOf)
 import Plutarch.Monadic qualified as P
 import Plutarch.Prelude
-import Plutarch.Builtin (pfromDataImpl, pdataImpl)
-import Plutarch.LedgerApi.Value (PCurrencySymbol, pvalueOf)
-import Plutarch.Core.Utils (ptryLookupValue, pheadSingleton, pand'List, (#>), pvalidateConditions)
 import Plutarch.Unsafe (punsafeCoerce)
-import Plutarch.Internal.PlutusType (PlutusType(pcon', pmatch'))
---import SmartTokens.Types.PTokenDirectory (PDirectorySetNode)
+import PlutusTx qualified
+
+data SmartTokenMintingAction = RegisterPToken | MintPToken
+  deriving stock (Show, Eq, Generic)
+
+instance PlutusTx.ToData SmartTokenMintingAction where
+  toBuiltinData RegisterPToken = PlutusTx.toBuiltinData (0 :: Integer)
+  toBuiltinData MintPToken = PlutusTx.toBuiltinData (1 :: Integer)
 
 data PSmartTokenMintingAction (s :: S) = PRegisterPToken | PMintPToken
 
@@ -27,7 +39,7 @@ instance PlutusType PSmartTokenMintingAction where
   pcon' PRegisterPToken = 0
   pcon' PMintPToken = 1
 
-  -- redeemer data is untrusted and non-permanent so we can safely decide zero is 
+  -- redeemer data is untrusted and non-permanent so we can safely decide zero is
   -- PRegisterPToken and anything else we consider PMintPToken.
   pmatch' x f =
     pif (x #== 0) (f PRegisterPToken) (f PMintPToken)
@@ -39,6 +51,7 @@ instance PIsData PSmartTokenMintingAction where
     pdataImpl x =
         pdataImpl $ pto x
 
+
 mkProgrammableLogicMinting :: ClosedTerm (PAsData PCredential :--> PAsData PCredential :--> PAsData PCurrencySymbol :--> PScriptContext :--> PUnit)
 mkProgrammableLogicMinting = plam $ \programmableLogicBase mintingLogicCred nodeCS ctx -> P.do
   ctxF <- pletFields @'["txInfo", "redeemer", "scriptInfo"] ctx
@@ -55,7 +68,7 @@ mkProgrammableLogicMinting = plam $ \programmableLogicBase mintingLogicCred node
   ownTokenName <- plet (pfstBuiltin # ownTkPair)
   ownNumMinted <- plet (pfromData $ psndBuiltin # ownTkPair)
   txOutputs <- plet $ pfromData infoF.outputs
-  -- For ease of implementation of the POC we enforce that the first output must contain the minted tokens. 
+  -- For ease of implementation of the POC we enforce that the first output must contain the minted tokens.
   -- This can be easily changed later.
   mintingToOutputF <- pletFields @'["value", "address"] (phead # txOutputs)
 
@@ -69,7 +82,7 @@ mkProgrammableLogicMinting = plam $ \programmableLogicBase mintingLogicCred node
     -- It creates a permanent association between the currency symbol with a transferLogicScript and issuerLogicScript.
     -- All transfers of the token will be validated by either the transferLogicScript or the issuerLogicScript.
     -- This redeemer can only be invoked once per instance of this minting policy since the directory contracts do not permit duplicate
-    -- entries. 
+    -- entries.
     PRegisterPToken -> P.do
       let nodeTkPairs = ptryLookupValue # nodeCS # mintedValue
       nodeTkPair <- plet (pheadSingleton # nodeTkPairs)

src/lib/Wst/Offchain/BuildTx/DirectorySet.hs

@@ -14,81 +14,83 @@ import Cardano.Api.Shelley qualified as C
 import Control.Lens (over)
 import Convex.BuildTx (MonadBuildTx, addBtx, mintPlutus)
 import Convex.CardanoApi.Lenses qualified as L
-import Convex.PlutusLedger.V1 (unTransAssetName)
+import Convex.Class (MonadBlockchain, queryNetworkId)
+import Convex.PlutusLedger.V1 (transStakeCredential, unTransAssetName)
 import Convex.Scripts (fromHashableScriptData, toHashableScriptData)
+import Convex.Utils qualified as Utils
 import GHC.Exts (IsList (..))
-import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..))
-import PlutusLedgerApi.V3 qualified as P
+import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..), TokenName (..))
 import SmartTokens.LinkedList.MintDirectory (DirectoryNodeAction (..))
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.Scripts (directoryNodeMintingScript,
                              directoryNodeSpendingScript, scriptPolicyIdV3)
 
 -- TODO: Where should this go
 directoryNodeToken :: C.AssetName
-directoryNodeToken = unTransAssetName $ P.TokenName "DirectoryNodeNFT"
+directoryNodeToken = unTransAssetName $ TokenName "DirectoryNodeNFT"
 
-initDirectorySet :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.PolicyId -> C.TxIn -> m ()
-initDirectorySet netId paramsPolicyId txIn = do
+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
 
   let
-      val = C.TxOutValueShelleyBased C.ShelleyBasedEraConway $ C.toLedgerValue C.MaryEraOnwardsBabbage
+      val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
             $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) directoryNodeToken, 1)]
 
       addr =
         C.makeShelleyAddressInEra
-          C.ShelleyBasedEraConway
+          C.shelleyBasedEra
           netId
           (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId)
           C.NoStakeAddress
 
       d = DirectorySetNode (CurrencySymbol "") (CurrencySymbol "") (PubKeyCredential "") (PubKeyCredential "")
-      dat = C.TxOutDatumInline C.BabbageEraOnwardsConway $ toHashableScriptData d
+      dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData d
 
-      output :: C.TxOut C.CtxTx C.ConwayEra
       output = C.TxOut addr val dat C.ReferenceScriptNone
 
   addBtx (over L.txOuts (output :))
 
-insertDirectoryNode :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.PolicyId -> C.TxIn -> (C.TxIn, C.InAnyCardanoEra (C.TxOut ctx)) -> (CurrencySymbol, Credential, Credential) -> m ()
-insertDirectoryNode netId paramsPolicyId initialTxIn (_, firstTxOut) (newKey, transferLogic, issuerLogic) = do
+insertDirectoryNode :: forall era m ctx. (C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => C.PolicyId -> C.TxIn -> (C.TxIn, C.TxOut ctx era) -> (CurrencySymbol, C.StakeCredential, C.StakeCredential) -> m ()
+insertDirectoryNode paramsPolicyId initialTxIn (_, firstTxOut) (newKey, transferLogic, issuerLogic) = Utils.inBabbage @era $ do
+  netId <- queryNetworkId
 
   let
       directoryMintingScript = directoryNodeMintingScript initialTxIn
 
-      (firstTxVal :: C.TxOutValue C.ConwayEra, firstTxData :: DirectorySetNode) = case firstTxOut of
-        C.InAnyCardanoEra _ (C.TxOut _ v (C.TxOutDatumInline C.BabbageEraOnwardsConway dat) _) -> case fromHashableScriptData @DirectorySetNode dat of
+      firstTxVal :: C.TxOutValue era
+      (firstTxVal, firstTxData) = case firstTxOut of
+        (C.TxOut _ v (C.TxOutDatumInline _ dat) _) -> case fromHashableScriptData @DirectorySetNode dat of
           Just d -> (v, d)
           Nothing -> error "insertDirectoryNode: invalid datum"
         _ -> error "insertDirectoryNode: invalid output"
 
-      newVal = C.TxOutValueShelleyBased C.ShelleyBasedEraConway $ C.toLedgerValue C.MaryEraOnwardsBabbage
+      newVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
           $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) directoryNodeToken, 1)]
 
       addr =
         C.makeShelleyAddressInEra
-          C.ShelleyBasedEraConway
+          C.shelleyBasedEra
           netId
           (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId )
           C.NoStakeAddress
 
-      x = DirectorySetNode
+      dsn = DirectorySetNode
             { key = newKey
             , next = next firstTxData
-            , transferLogicScript = transferLogic
-            , issuerLogicScript = issuerLogic
+            , transferLogicScript = transStakeCredential transferLogic
+            , issuerLogicScript = transStakeCredential issuerLogic
             }
-      newDat = C.TxOutDatumInline C.BabbageEraOnwardsConway $ toHashableScriptData x
+      newDat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData dsn
 
-      newOutput :: C.TxOut C.CtxTx C.ConwayEra
       newOutput = C.TxOut addr newVal newDat C.ReferenceScriptNone
 
       firstDat = firstTxData { next = newKey}
-      firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.BabbageEraOnwardsConway $ toHashableScriptData firstDat) C.ReferenceScriptNone
+      firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData firstDat) C.ReferenceScriptNone
 
   mintPlutus directoryMintingScript (InsertDirectoryNode newKey) directoryNodeToken 1
   addBtx (over L.txOuts (newOutput :))

src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs

@@ -1,46 +1,68 @@
+{-# LANGUAGE NamedFieldPuns   #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies     #-}
 {-# LANGUAGE ViewPatterns     #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {-# HLINT ignore "Redundant if" #-}
+{-# HLINT ignore "Use second" #-}
 module Wst.Offchain.BuildTx.ProgrammableLogic
-  ( transferProgrammableToken,
+  ( issueProgrammableToken,
+    transferProgrammableToken,
     seizePragrammableToken,
   )
 where
 
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
-import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody,
-                       buildScriptWitness, findIndexReference, mintPlutus,
-                       spendPlutusInlineDatum)
-import Convex.PlutusLedger.V1 (transPolicyId)
+import Convex.BuildTx (MonadBuildTx, addReference,
+                       addWithdrawZeroPlutusV2InTransaction, addWithdrawal,
+                       addWithdrawalWithTxBody, buildScriptWitness,
+                       findIndexReference, mintPlutus, spendPlutusInlineDatum)
+import Convex.Class (MonadBlockchain (queryNetworkId))
+import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
+                               unTransPolicyId)
 import Convex.Scripts (fromHashableScriptData)
-import Data.Foldable (maximumBy)
+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 SmartTokens.Contracts.Issuance (SmartTokenMintingAction (MintPToken, RegisterPToken))
+import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
+import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode)
+import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline)
 import Wst.Offchain.Scripts (programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
 
 -- Takes care of both registrations and token mints
-issueProgrammableToken :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.TxIn -> (C.AssetName, C.Quantity) -> Credential -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))]-> m CurrencySymbol
-issueProgrammableToken nid paramsTxIn (an, q) mintingCred directoyrList = do
+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
 
-  let paymentCred = undefined
-      mintingCred = undefined
-      nodeCS = undefined
+  ProgrammableLogicGlobalParams{directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut)
 
-  let mintingScript = programmableLogicMintingScript paymentCred mintingCred nodeCS
+  progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred
+  directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS
 
-  addReference paramsTxIn
-  let policyId = transPolicyId $ C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
-  -- addStakeScriptWitness mintingCred (programmableLogicMintingScript mintingCred) () -- TODO: minting logic redeemer
+  let mintingScript = programmableLogicMintingScript progLogicScriptCredential mintingCred directoryNodeSymbol
+      policyId = transPolicyId $ C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
+
+      (dirNodeRef, dirNodeOut) =
+        maximumBy (compare `on` (fmap key . getDirectoryNodeInline . C.inAnyCardanoEra (C.cardanoEra @era) . snd)) $
+          filter (maybe False ((<= policyId) . key) . getDirectoryNodeInline . C.inAnyCardanoEra (C.cardanoEra @era) . snd) directoryList
+
+  dirNodeData <- maybe (error "could not parse directory node data") pure $ getDirectoryNodeInline $ C.inAnyCardanoEra (C.cardanoEra @era) dirNodeOut
 
-  -- TODO: register token redeemer should go here
-  mintPlutus mintingScript () an q
+  if key dirNodeData == policyId
+    then
+      mintPlutus mintingScript MintPToken an q
+    else
+      mintPlutus mintingScript RegisterPToken an q
+      >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic)
 
   pure policyId
 

src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Wst.Offchain.BuildTx.ProtocolParams (
-  mintProtocolParams
+  mintProtocolParams,
+  getProtocolParamsGlobalInline
 ) where
 
 import Cardano.Api qualified as C
@@ -10,7 +11,7 @@ import Convex.BuildTx (MonadBuildTx, mintPlutus, prependTxOut,
                        spendPublicKeyOutput)
 import Convex.Class (MonadBlockchain (..))
 import Convex.PlutusLedger.V1 (unTransAssetName)
-import Convex.Scripts (toHashableScriptData)
+import Convex.Scripts (fromHashableScriptData, toHashableScriptData)
 import Convex.Utils qualified as Utils
 import GHC.Exts (IsList (..))
 import SmartTokens.Types.Constants (protocolParamsToken)
@@ -46,3 +47,9 @@ mintProtocolParams params txIn = Utils.inBabbage @era $ do
   spendPublicKeyOutput txIn
   mintPlutus mintingScript () protocolParamsTokenC 1
   prependTxOut output
+
+getProtocolParamsGlobalInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe ProgrammableLogicGlobalParams
+getProtocolParamsGlobalInline (C.InAnyCardanoEra _ (C.TxOut _ _ dat _)) =
+  case dat of
+    C.TxOutDatumInline _era (fromHashableScriptData -> Just d) -> Just d
+    _ -> Nothing