Add script target parameter (debug / production) (#37)

* Add ScriptTarget flag

* Add build target in one place

* WIP - script dependencies

* Fix build error

* Use scripts from env everywhere

* Parameterise tests by script target

* Delete node params (not required anymore)

* Add filter for NFT to globalParamsNode

* 10x ex units and memory for testing

* Rename workflow

* github action: Fix concurrency group

.github/workflows/ci-compiled-scripts.yaml

@@ -1,12 +1,12 @@
-name: ci-linux
+name: ci-check-generated-code
 on:
   push:
     branches:
       - main
   pull_request:
 
 concurrency:
-  group: ${{ github.ref }}
+  group: "check-generated-code ${{ github.ref }}"
   cancel-in-progress: true
 
 jobs:

src/lib/SmartTokens/Core/Scripts.hs

@@ -1,18 +1,46 @@
 module SmartTokens.Core.Scripts (
+  -- * Build targets
+  ScriptTarget(..),
+  targetConfig,
+
+  -- * Compile functions
   tryCompile,
   tryCompileTracingAndBinds,
   tryCompileNoTracing,
 ) where
 
+import Data.Aeson (FromJSON, ToJSON)
+import GHC.Generics (Generic)
 import Plutarch
 
-tryCompile :: Config -> ClosedTerm a -> Script
-tryCompile cfg x = case compile cfg x of
+{-| Script target environment
+-}
+data ScriptTarget
+  = Debug -- ^ Include debug symbols
+  | Production -- ^ No debug symbols
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+{-| The plutarch 'Config' for the target
+-}
+targetConfig :: ScriptTarget -> Config
+targetConfig = \case
+  Debug      -> tracingAndBindsConfig
+  Production -> prodConfig
+
+tryCompile :: ScriptTarget -> ClosedTerm a -> Script
+tryCompile tgt x = case compile (targetConfig tgt) x of
   Left e -> error $ "Compilation failed: " <> show e
   Right s -> s
 
 tryCompileTracingAndBinds :: ClosedTerm a -> Script
-tryCompileTracingAndBinds = tryCompile (Tracing LogInfo DoTracingAndBinds)
+tryCompileTracingAndBinds = tryCompile Debug
 
 tryCompileNoTracing :: ClosedTerm a -> Script
-tryCompileNoTracing = tryCompile NoTracing
+tryCompileNoTracing = tryCompile Production
+
+tracingAndBindsConfig :: Config
+tracingAndBindsConfig = Tracing LogInfo DoTracingAndBinds
+
+prodConfig :: Config
+prodConfig = NoTracing

src/lib/Wst/Cli.hs

@@ -12,6 +12,7 @@ import Data.Proxy (Proxy)
 import Data.String (IsString (..))
 import Options.Applicative (customExecParser, disambiguate, helper, idm, info,
                             prefs, showHelpOnEmpty, showHelpOnError)
+import SmartTokens.Core.Scripts (ScriptTarget (Production))
 import Wst.App (runWstApp)
 import Wst.Cli.Command (Command (..), ManageCommand (StartServer, Status),
                         parseCommand)
@@ -32,7 +33,7 @@ runCommand com = do
   result <- case com of
     Deploy config -> runWstApp env (deploy config)
     Manage txIn com_ -> do
-      let env' = Env.addDirectoryEnvFor txIn env
+      let env' = Env.addDirectoryEnvFor (Env.DirectoryScriptRoot txIn Production) env
       runWstApp env' $ case com_ of
         Status -> do
           -- TODO: status check (call the query endpoints and print out a summary of the results)

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

@@ -36,8 +36,7 @@ import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
-import Wst.Offchain.Scripts (directoryNodeMintingScript,
-                             directoryNodeSpendingScript, scriptPolicyIdV3)
+import Wst.Offchain.Scripts (scriptPolicyIdV3)
 
 _unused :: String
 _unused = _printTerm $ unsafeEvalTerm NoTracing (pconstantData initialNode)
@@ -57,22 +56,21 @@ initialNode = DirectorySetNode
 
 initDirectorySet :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m ()
 initDirectorySet = Utils.inBabbage @era $ do
-  txIn <- asks (Env.dsTxIn . Env.directoryEnv)
-  paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv)
   netId <- queryNetworkId
-  let mintingScript = directoryNodeMintingScript txIn
+  directoryMintingScript <- asks (Env.dsDirectoryMintingScript . Env.directoryEnv)
+  directorySpendingScript <- asks (Env.dsDirectorySpendingScript . Env.directoryEnv)
 
-  mintPlutus mintingScript InitDirectory (unTransAssetName directoryNodeToken) 1
+  mintPlutus directoryMintingScript InitDirectory (unTransAssetName directoryNodeToken) 1
 
   let
       val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
-            $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) (unTransAssetName directoryNodeToken), 1)]
+            $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) (unTransAssetName directoryNodeToken), 1)]
 
       addr =
         C.makeShelleyAddressInEra
           C.shelleyBasedEra
           netId
-          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId)
+          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 directorySpendingScript)
           C.NoStakeAddress
 
       dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData initialNode
@@ -95,7 +93,6 @@ data InsertNodeArgs =
 insertDirectoryNode :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => UTxODat era ProgrammableLogicGlobalParams -> UTxODat era DirectorySetNode -> InsertNodeArgs -> m ()
 insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum=firstTxData} InsertNodeArgs{inaNewKey, inaTransferLogic, inaIssuerLogic} = Utils.inBabbage @era $ do
   netId <- queryNetworkId
-  paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv)
   directorySpendingScript <- asks (Env.dsDirectorySpendingScript . Env.directoryEnv)
   directoryMintingScript <- asks (Env.dsDirectoryMintingScript . Env.directoryEnv)
   let
@@ -115,7 +112,7 @@ insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum=
         C.makeShelleyAddressInEra
           C.shelleyBasedEra
           netId
-          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId )
+          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 directorySpendingScript)
           C.NoStakeAddress
 
       dsn = DirectorySetNode

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

@@ -6,13 +6,7 @@
 
 {-# HLINT ignore "Use second" #-}
 module Wst.Offchain.BuildTx.ProgrammableLogic
-  (
-    IssueNewTokenArgs (..),
-    alwaysSucceedsArgs,
-    fromTransferEnv,
-    programmableTokenMintingScript,
-    programmableTokenAssetId,
-    issueProgrammableToken,
+  ( issueProgrammableToken,
     transferProgrammableToken,
     seizeProgrammableToken,
   )
@@ -21,17 +15,16 @@ where
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
 import Control.Lens ((^.))
+import Control.Monad (unless)
 import Control.Monad.Reader (MonadReader, asks)
 import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody,
                        buildScriptWitness, findIndexReference,
                        findIndexSpending, mintPlutus, prependTxOut,
                        spendPlutusInlineDatum)
 import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
-import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
-                               unTransPolicyId)
+import Convex.PlutusLedger.V1 (transPolicyId)
 import Convex.Utils qualified as Utils
-import Data.Either (fromRight)
 import Data.Foldable (find, maximumBy, traverse_)
 import Data.Function (on)
 import Data.List (partition)
@@ -48,59 +41,26 @@ import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..),
 import Wst.Offchain.Env (TransferLogicEnv (..))
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
-import Wst.Offchain.Scripts (alwaysSucceedsScript,
-                             programmableLogicMintingScript)
-
-data IssueNewTokenArgs = IssueNewTokenArgs
-  { intaMintingLogic  :: C.PlutusScript C.PlutusScriptV3, -- TODO: We could add a parameter for the script 'lang' instead of fixing it to PlutusV3
-    intaTransferLogic :: C.PlutusScript C.PlutusScriptV3,
-    intaIssuerLogic   :: C.PlutusScript C.PlutusScriptV3
-  }
-
-{-| 'IssueNewTokenArgs' for the policy that always succeeds (no checks)
--}
-alwaysSucceedsArgs :: IssueNewTokenArgs
-alwaysSucceedsArgs =
-  IssueNewTokenArgs
-    { intaMintingLogic = alwaysSucceedsScript
-    , intaTransferLogic = alwaysSucceedsScript
-    , intaIssuerLogic = alwaysSucceedsScript
-    }
-
-{-| 'IssueNewTokenArgs' for the transfer logic
--}
-fromTransferEnv :: TransferLogicEnv -> IssueNewTokenArgs
-fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerScript} =
-  IssueNewTokenArgs
-    { intaMintingLogic  = tleMintingScript
-    , intaTransferLogic = tleTransferScript
-    , intaIssuerLogic   = tleIssuerScript
-    }
-
-{-| The minting script for a programmable token that uses the global parameters
--}
-programmableTokenMintingScript :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.PlutusScript C.PlutusScriptV3
-programmableTokenMintingScript ProgrammableLogicGlobalParams {progLogicCred, directoryNodeCS} IssueNewTokenArgs{intaMintingLogic} =
-  let progLogicScriptCredential = fromRight (error "could not parse protocol params") $ unTransCredential progLogicCred
-      directoryNodeSymbol       = fromRight (error "could not parse protocol params") $ unTransPolicyId directoryNodeCS
-  in programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol
-
-{-| 'C.AssetId' of the programmable tokens
--}
-programmableTokenAssetId :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.AssetName -> C.AssetId
-programmableTokenAssetId params inta =
-  C.AssetId
-    (C.scriptPolicyId $ C.PlutusScript C.plutusScriptVersion $ programmableTokenMintingScript params inta)
-
 
 {- 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 env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> m C.PolicyId
-issueProgrammableToken paramsTxOut (an, q) inta@IssueNewTokenArgs{intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do
-  let mintingScript = programmableTokenMintingScript (uDatum paramsTxOut) inta
+issueProgrammableToken :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> m C.PolicyId
+issueProgrammableToken paramsTxOut (an, q) directoryList = Utils.inBabbage @era $ do
+  inta@TransferLogicEnv{tleTransferScript, tleIssuerScript} <- asks Env.transferLogicEnv
+  glParams <- asks (Env.globalParams . Env.directoryEnv)
+  dir <- asks Env.directoryEnv
+
+  -- The global params in the UTxO need to match those in our 'DirectoryEnv'.
+  -- If they don't, we get a script error when trying to balance the transaction.
+  -- To avoid this we check for equality here and fail early.
+  unless (glParams == uDatum paramsTxOut) $
+    -- FIXME: Error handling
+    error "Global params do not match"
+
+  let mintingScript = Env.programmableTokenMintingScript dir inta
       issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
       issuedSymbol = transPolicyId issuedPolicyId
 
@@ -115,8 +75,8 @@ issueProgrammableToken paramsTxOut (an, q) inta@IssueNewTokenArgs{intaTransferLo
       let nodeArgs =
             InsertNodeArgs
               { inaNewKey = issuedSymbol
-              , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaTransferLogic
-              , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaIssuerLogic
+              , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion tleTransferScript
+              , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion tleIssuerScript
               }
 
       mintPlutus mintingScript RegisterPToken an q

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Wst.Offchain.BuildTx.ProtocolParams (
   mintProtocolParams,
   getProtocolParamsGlobalInline
@@ -15,9 +16,9 @@ import Convex.Utils qualified as Utils
 import GHC.Exts (IsList (..))
 import SmartTokens.Types.Constants (protocolParamsToken)
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
+import Wst.Offchain.Env (DirectoryEnv (..))
 import Wst.Offchain.Env qualified as Env
-import Wst.Offchain.Scripts (protocolParamsMintingScript,
-                             protocolParamsSpendingScript, scriptPolicyIdV3)
+import Wst.Offchain.Scripts (scriptPolicyIdV3)
 
 protocolParamsTokenC :: C.AssetName
 protocolParamsTokenC = unTransAssetName protocolParamsToken
@@ -26,13 +27,11 @@ protocolParamsTokenC = unTransAssetName protocolParamsToken
 -}
 mintProtocolParams :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => m ()
 mintProtocolParams = Utils.inBabbage @era $ do
-  txIn <- asks (Env.dsTxIn . Env.directoryEnv)
+  txIn <- asks (Env.srTxIn . Env.dsScriptRoot . Env.directoryEnv)
   params <- asks (Env.globalParams . Env.directoryEnv)
   netId <- queryNetworkId
-  let
-      mintingScript = protocolParamsMintingScript txIn
-
-      policyId = scriptPolicyIdV3 mintingScript
+  DirectoryEnv{dsProtocolParamsMintingScript, dsProtocolParamsSpendingScript} <- asks Env.directoryEnv
+  let policyId = scriptPolicyIdV3 dsProtocolParamsMintingScript
 
       val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
             $ fromList [(C.AssetId policyId protocolParamsTokenC, 1)]
@@ -41,7 +40,7 @@ mintProtocolParams = Utils.inBabbage @era $ do
         C.makeShelleyAddressInEra
           C.shelleyBasedEra
           netId
-          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 protocolParamsSpendingScript)
+          (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 dsProtocolParamsSpendingScript)
           C.NoStakeAddress
 
       -- Should contain directoryNodeCS and progLogicCred fields
@@ -51,7 +50,7 @@ mintProtocolParams = Utils.inBabbage @era $ do
       output = C.TxOut addr val dat C.ReferenceScriptNone
 
   spendPublicKeyOutput txIn
-  mintPlutus mintingScript () protocolParamsTokenC 1
+  mintPlutus dsProtocolParamsMintingScript () protocolParamsTokenC 1
   prependTxOut output
 
 getProtocolParamsGlobalInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe ProgrammableLogicGlobalParams

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

@@ -44,24 +44,13 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (BlacklistNode (..),
                                           DirectorySetNode (..))
 import Wst.AppError (AppError (TransferBlacklistedCredential))
-import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs (..),
-                                               issueProgrammableToken,
+import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken,
                                                seizeProgrammableToken,
                                                transferProgrammableToken)
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
 import Wst.Offchain.Scripts (scriptPolicyIdV3)
 
-intaFromEnv :: forall env m. (MonadReader env m, Env.HasTransferLogicEnv env)=> m IssueNewTokenArgs
-intaFromEnv = do
-  Env.TransferLogicEnv{Env.tleIssuerScript, Env.tleMintingScript, Env.tleTransferScript} <- asks Env.transferLogicEnv
-  pure $ IssueNewTokenArgs
-    { intaTransferLogic= tleTransferScript
-    , intaMintingLogic= tleMintingScript
-    , intaIssuerLogic= tleIssuerScript
-    }
-
-
 {-
 >>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode)
 "program\n  1.0.0\n  (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])"
@@ -157,10 +146,7 @@ paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBab
 
 issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId
 issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBabbage @era $ do
-  inta <- intaFromEnv
-  issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList
-
-
+  issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) directoryList
   addIssueWitness
   --  payToAddress addr value
   paySmartTokensToDestination (an, q) issuedPolicyId destinationCred