Add query for programmable logic UTxOs

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

@@ -19,7 +19,7 @@ where
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
 import Control.Lens (over, (^.))
-import Control.Monad.Reader (MonadReader, asks, runReaderT)
+import Control.Monad.Reader (MonadReader, asks)
 import Convex.BuildTx (MonadBuildTx, addBtx, addReference,
                        addWithdrawalWithTxBody, buildScriptWitness,
                        findIndexReference, findIndexSpending, mintPlutus,
@@ -28,7 +28,7 @@ import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
 import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
                                unTransPolicyId)
-import Convex.Scripts (fromHashableScriptData)
+import Convex.Scripts (toHashableScriptData)
 import Convex.Utils qualified as Utils
 import Data.Foldable (find, maximumBy, traverse_)
 import Data.Function (on)
@@ -42,42 +42,38 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..),
                                           insertDirectoryNode)
-import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline)
 import Wst.Offchain.Env (DirectoryEnv (..), TransferLogicEnv (..))
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
-import Wst.Offchain.Query qualified as Query
 import Wst.Offchain.Scripts (alwaysSucceedsScript, programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
 
 data IssueNewTokenArgs = IssueNewTokenArgs
-  { intaMintingLogic :: C.StakeCredential,
-    intaTransferLogic :: C.StakeCredential,
-    intaIssuerLogic :: C.StakeCredential
+  { 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 =
-  let credential = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion alwaysSucceedsScript
-  in IssueNewTokenArgs
-      { intaMintingLogic = credential
-      , intaTransferLogic = credential
-      , intaIssuerLogic = credential
-      }
+  IssueNewTokenArgs
+    { intaMintingLogic = alwaysSucceedsScript
+    , intaTransferLogic = alwaysSucceedsScript
+    , intaIssuerLogic = alwaysSucceedsScript
+    }
 
 {-| 'IssueNewTokenArgs' for the transfer logic
 -}
 fromTransferEnv :: TransferLogicEnv -> IssueNewTokenArgs
 fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerScript} =
-  let hsh = C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.plutusScriptVersion
-  in IssueNewTokenArgs
-      { intaMintingLogic  = hsh tleMintingScript
-      , intaTransferLogic = hsh tleTransferScript
-      , intaIssuerLogic   = hsh tleIssuerScript
-      }
+  IssueNewTokenArgs
+    { intaMintingLogic  = tleMintingScript
+    , intaTransferLogic = tleTransferScript
+    , intaIssuerLogic   = tleIssuerScript
+    }
 
 {- 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.
@@ -94,7 +90,7 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
   DirectoryEnv{dsProgrammableLogicBaseScript} <- asks Env.directoryEnv
 
   -- TODO: maybe move programmableLogicMintingScript to DirectoryEnv
-  let mintingScript = programmableLogicMintingScript progLogicScriptCredential intaMintingLogic directoryNodeSymbol
+  let mintingScript = programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol
       issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
       issuedSymbol = transPolicyId issuedPolicyId
 
@@ -112,16 +108,24 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
       receivingVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
         $ fromList [(C.AssetId issuedPolicyId an, q)]
 
+      dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData () -- TODO: What should the datum be?
+
   if key dirNodeData == issuedSymbol
     then
       mintPlutus mintingScript MintPToken an q
     else do
-      let nodeArgs  = InsertNodeArgs{inaNewKey = issuedSymbol, inaTransferLogic = intaTransferLogic, inaIssuerLogic = intaIssuerLogic}
+      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
+              }
+
       mintPlutus mintingScript RegisterPToken an q
       insertDirectoryNode paramsTxOut udat nodeArgs
 
       -- add programmable logic output
-      prependTxOut $ C.TxOut receivingAddress receivingVal C.TxOutDatumNone C.ReferenceScriptNone
+      prependTxOut $ C.TxOut receivingAddress receivingVal dat C.ReferenceScriptNone
 
   pure issuedPolicyId
 
@@ -261,10 +265,3 @@ checkIssuerAddressIsProgLogicCred _ _ = error "Issuer address is not a programma
 
 isNodeWithProgrammableSymbol :: forall era. CurrencySymbol -> UTxODat era DirectorySetNode -> Bool
 isNodeWithProgrammableSymbol programmableTokenSymbol (uDatum -> dat) = key dat == programmableTokenSymbol
-
-getDirectoryNodeInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe DirectorySetNode
-getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) =
-  case dat of
-    C.TxOutDatumInline C.BabbageEraOnwardsConway (fromHashableScriptData -> Just d) -> Just d
-    _ -> Nothing
-getDirectoryNodeInline _ = Nothing

src/lib/Wst/Offchain/Endpoints/Deployment.hs

@@ -20,7 +20,6 @@ import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
 import Wst.Offchain.Env (BuildTxError)
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query qualified as Query
-import Wst.Offchain.Scripts qualified as Scripts
 
 {-| Build a transaction that deploys the directory and global params. Returns the
 transaction and the 'TxIn' that was selected for the one-shot NFTs.
@@ -66,11 +65,8 @@ issueProgrammableTokenTx issueTokenArgs assetName quantity = do
   directory <- Query.registryNodes @era
   paramsNode <- head <$> Query.globalParamsNode @era
   (tx, _) <- Env.balanceTxEnv $ do
-    BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory
+    _ <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory
 
-    -- FIXME: We need the actual script here, not just the hash
-    let script = C.PlutusScript C.plutusScriptVersion Scripts.alwaysSucceedsScript
-        hsh = C.hashScript script
-        cred = C.StakeCredentialByScript hsh
-    BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness Scripts.alwaysSucceedsScript C.NoScriptDatumForStake ()
+    let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs)
+    BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness (BuildTx.intaMintingLogic issueTokenArgs) C.NoScriptDatumForStake ()
   pure (Convex.CoinSelection.signBalancedTxBody [] tx)

src/lib/Wst/Offchain/Query.hs

@@ -5,6 +5,7 @@ module Wst.Offchain.Query(
   -- * Queries
   registryNodes,
   globalParamsNode,
+  programmableLogicOutputs,
 
   -- * UTxO with datum
   UTxODat(..),
@@ -24,7 +25,7 @@ import Data.Maybe (mapMaybe)
 import PlutusTx qualified
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
-import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript),
+import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript),
                          HasDirectoryEnv (directoryEnv))
 import Wst.Offchain.Scripts (protocolParamsSpendingScript)
 
@@ -53,6 +54,13 @@ globalParamsNode = do
   let cred = C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 $ protocolParamsSpendingScript
   fmap (extractUTxO @era) (utxosByPaymentCredential cred)
 
+{-| Outputs that are locked by the programmable logic base script.
+-}
+programmableLogicOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era ()]
+programmableLogicOutputs = do
+  asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript . directoryEnv)
+    >>= fmap (extractUTxO @era) . utxosByPaymentCredential
+
 fromOutput :: forall era a. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => C.TxIn -> C.TxOut C.CtxUTxO era -> Maybe (UTxODat era a)
 fromOutput uIn uOut@(L.preview (L._TxOut . L._3 . L._TxOutDatumInline) >=> fromHashableScriptData -> Just uDatum) = Just UTxODat{uIn, uOut, uDatum}
 fromOutput _ _ = Nothing

src/test/Wst/Test/UnitTest.hs

@@ -33,6 +33,7 @@ tests = testGroup "unit tests"
   , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode)
   , testGroup "issue programmable tokens"
       [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator)
+      -- TODO: Add test for the seize/freeze validator
       ]
   ]
 
@@ -59,11 +60,20 @@ insertDirectoryNode = failOnError $ do
 -}
 issueAlwaysSucceedsValidator :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m ()
 issueAlwaysSucceedsValidator = failOnError $ do
+
+  -- Register the stake validator
+  -- Oddly, the tests passes even if we don't do this.
+  -- But I'll leave it in because it seems right.
   registerAlwaysSucceedsStakingCert
+
   txI <- deployDirectorySet
   asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do
     Endpoints.issueProgrammableTokenTx alwaysSucceedsArgs "dummy asset" 100
       >>= void . sendTx . signTxOperator admin
+    Query.registryNodes @C.ConwayEra
+      >>= void . expectN 2 "registry outputs"
+    Query.programmableLogicOutputs @C.ConwayEra
+      >>= void . expectN 1 "programmable logic outputs"
   pure ()
 
 
@@ -75,6 +85,8 @@ dummyNodeArgs =
     , inaIssuerLogic = C.StakeCredentialByScript "e165610232235bbbbeff5b998b23e165610232235bbbbeff5b998b23"
     }
 
+{-| Register the 'alwaysSucceedsScript' stake validator
+-}
 registerAlwaysSucceedsStakingCert :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m ()
 registerAlwaysSucceedsStakingCert = failOnError $ do
   pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters