fix build issues

src/lib/SmartTokens/Types/PTokenDirectory.hs

@@ -23,6 +23,7 @@ module SmartTokens.Types.PTokenDirectory (
   pletFieldsBlacklistNode,
   pisEmptyNode,
   BlacklistNode(..),
+  pdeserializeCredential,
 ) where
 
 import Generics.SOP qualified as SOP
@@ -257,13 +258,28 @@ pisInsertedOnNode = phoistAcyclic $
 pisInsertedNode :: ClosedTerm (PAsData PByteString :--> PAsData PByteString :--> PAsData PDirectorySetNode :--> PBool)
 pisInsertedNode = phoistAcyclic $
   plam $ \insertedKey coveringNext outputNode ->
-    pletFields @'["transferLogicScript", "issuerLogicScript", "key", "next"] outputNode $ \outputNodeDatumF ->
-      let transferLogicCred_ = outputNodeDatumF.transferLogicScript
-          issuerLogicCred_ = outputNodeDatumF.issuerLogicScript
+    pletFields @'["transferLogicScript", "issuerLogicScript"] outputNode $ \outputNodeDatumF ->
+      let transferLogicCred_ = ptraceInfoShowId outputNodeDatumF.transferLogicScript
+          issuerLogicCred_ = ptraceInfoShowId outputNodeDatumF.issuerLogicScript
           expectedDirectoryNode =
-            pmkDirectorySetNode # insertedKey # coveringNext # pdeserializeCredential transferLogicCred_ # pdeserializeCredential issuerLogicCred_
+            pmkDirectorySetNode # insertedKey # coveringNext # pdeserializeDirectoryCredential transferLogicCred_ # pdeserializeDirectoryCredential issuerLogicCred_
       in outputNode #== expectedDirectoryNode
 
+pdeserializeDirectoryCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential)
+pdeserializeDirectoryCredential term =
+  plet (pasConstr # pforgetData term) $ \constrPair ->
+    plet (pfstBuiltin # constrPair) $ \constrIdx ->
+      pif (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair))) #<= 28)
+          (
+            pcond
+              [ ( constrIdx #== 0 , term)
+              , ( constrIdx #== 1 , term)
+              ]
+              (ptraceInfoError "Invalid credential")
+          )
+          (ptraceInfoError $ pconstant "Invalid credential len" <> pshow (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair)))))
+
+-- TODO: move to catalyst library
 pdeserializeCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential)
 pdeserializeCredential term =
   plet (pasConstr # pforgetData term) $ \constrPair ->
@@ -274,6 +290,6 @@ pdeserializeCredential term =
               [ ( constrIdx #== 0 , term)
               , ( constrIdx #== 1 , term)
               ]
-              perror
+              (ptraceInfoError "Invalid credential")
           )
-          perror
+          (ptraceInfoError $ pconstant "Invalid credential len" <> pshow (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair)))))

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

@@ -125,12 +125,10 @@ insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum=
             , issuerLogicScript = transStakeCredential inaIssuerLogic
             }
       newDat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData dsn
-
       insertedNode = C.TxOut addr newVal newDat C.ReferenceScriptNone
 
       firstDat = firstTxData { next = inaNewKey }
       firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData firstDat) C.ReferenceScriptNone
-
   addReference paramsRef
   spendPlutusInlineDatum uIn directorySpendingScript ()
   mintPlutus directoryMintingScript (InsertDirectoryNode inaNewKey) newTokenName 1

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

@@ -119,8 +119,7 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
 
    IMPORTANT: The caller should ensure that the destination address of the
    programmable token(s) in this transaction all correspond to the same
-   programmable logic payment credential (even in the case of non-programmable
-   tokens) otherwise the transaction will fail onchain validation.
+   programmable logic payment credential otherwise the transaction will fail onchain validation.
 -}
 transferProgrammableToken :: forall env era 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.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m ()
 transferProgrammableToken _ _ _ [] = error "directory list not initialised"

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

@@ -69,7 +69,7 @@ intaFromEnv = do
 blacklistInitialNode :: BlacklistNode
 blacklistInitialNode =
   BlacklistNode
-    { blnNext= ""
+    { blnNext= "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"
     , blnKey= ""}
 
 initBlacklist :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m ()

src/lib/Wst/Offchain/Env.hs

@@ -55,7 +55,8 @@ module Wst.Offchain.Env(
   addRuntimeEnv,
   withRuntime,
   addOperatorEnv,
-  withOperator
+  withOperator,
+  blacklistNodePolicyId
 ) where
 
 import Blammo.Logging (Logger)
@@ -255,6 +256,9 @@ mkTransferLogicEnv progLogicBaseCred cred =
     , tleIssuerScript = permissionedTransferScript cred
     }
 
+blacklistNodePolicyId :: TransferLogicEnv -> C.PolicyId
+blacklistNodePolicyId = scriptPolicyIdV3 . tleBlacklistMintingScript
+
 data RuntimeEnv
   = RuntimeEnv
       { envLogger     :: Logger

src/lib/Wst/Offchain/Query.hs

@@ -28,6 +28,7 @@ import Convex.Utxos (UtxoSet, toApiUtxo)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Map qualified as Map
 import Data.Maybe (listToMaybe, mapMaybe)
+import GHC.Exts (IsList (..))
 import GHC.Generics (Generic)
 import PlutusTx qualified
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
@@ -36,7 +37,8 @@ import Wst.AppError (AppError (GlobalParamsNodeNotFound))
 import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript),
                          HasDirectoryEnv (directoryEnv),
                          HasTransferLogicEnv (transferLogicEnv),
-                         TransferLogicEnv (tleBlacklistSpendingScript))
+                         TransferLogicEnv (tleBlacklistSpendingScript),
+                         blacklistNodePolicyId, directoryNodePolicyId)
 import Wst.Offchain.Scripts (protocolParamsSpendingScript)
 
 -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs
@@ -55,16 +57,18 @@ data UTxODat era a =
 {-| Find all UTxOs that make up the registry
 -}
 registryNodes :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era DirectorySetNode]
-registryNodes =
-  asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv)
-    >>= fmap (extractUTxO @era) . utxosByPaymentCredential
+registryNodes = do
+  utxosAtDirectoryScript <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential
+  registryPolicy <- asks (directoryNodePolicyId . directoryEnv)
+  pure $ filter (utxoHasPolicyId registryPolicy) utxosAtDirectoryScript
 
 {-| Find all UTxOs that make up the blacklist
 -}
 blacklistNodes :: forall era env m. (MonadReader env m, HasTransferLogicEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era BlacklistNode]
-blacklistNodes =
-  asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv)
-    >>= fmap (extractUTxO @era) . utxosByPaymentCredential
+blacklistNodes = do
+  utxosAtBlacklistScript <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential
+  blacklistPolicy <- asks (blacklistNodePolicyId . transferLogicEnv)
+  pure $ filter (utxoHasPolicyId blacklistPolicy) utxosAtBlacklistScript
 
 userProgrammableOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadBlockchain era m) => C.PaymentCredential -> m [UTxODat era ()]
 userProgrammableOutputs userCred = do
@@ -105,3 +109,17 @@ fromOutput _ _ = Nothing
 
 extractUTxO :: forall era a b. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => UtxoSet C.CtxUTxO b -> [UTxODat era a]
 extractUTxO = mapMaybe (uncurry fromOutput) . Map.toList . C.unUTxO . toApiUtxo @era
+
+extractValue :: C.IsBabbageBasedEra era => C.TxOut C.CtxUTxO era -> C.Value
+extractValue = L.view $ L._TxOut . L._2 . L._TxOutValue
+
+hasPolicyId :: C.PolicyId -> C.Value -> Bool
+hasPolicyId policyId val =
+  let isPolicy :: (C.AssetId, C.Quantity) -> Bool
+      isPolicy (C.AssetId pid _, _) = pid == policyId
+      isPolicy _ = False
+  in any isPolicy (toList val)
+
+utxoHasPolicyId :: C.IsBabbageBasedEra era => C.PolicyId -> UTxODat era a -> Bool
+utxoHasPolicyId policyId txoD = hasPolicyId policyId $ extractValue (uOut txoD)
+

src/lib/Wst/Offchain/Scripts.hs

@@ -49,7 +49,10 @@ import SmartTokens.LinkedList.MintDirectory (mkDirectoryNodeMP)
 import SmartTokens.LinkedList.SpendDirectory (pmkDirectorySpending)
 
 tracingConfig :: Config
-tracingConfig = Tracing LogInfo DoTracingAndBinds
+tracingConfig = Tracing LogInfo DoTracing
+
+tracingAndBindsConfig :: Config
+tracingAndBindsConfig = Tracing LogInfo DoTracingAndBinds
 
 prodConfig :: Config
 prodConfig = NoTracing
@@ -60,34 +63,34 @@ prodConfig = NoTracing
 -- one shot mint
 protocolParamsMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3
 protocolParamsMintingScript txIn =
-  let script = tryCompile prodConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn)
+  let script = tryCompile tracingConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 -- | The spending script for the protocol parameters NFT parameterized by ""
 -- nonce
 protocolParamsSpendingScript :: C.PlutusScript C.PlutusScriptV3
 protocolParamsSpendingScript =
-  let script = tryCompile prodConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString))
+  let script = tryCompile tracingConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString))
   in C.PlutusScriptSerialised $ serialiseScript script
 
 -- | The minting script for the directory node tokens, takes initial TxIn for
 -- 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
 -- policy id of the protocol parameters NFT.
 directoryNodeSpendingScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3
 directoryNodeSpendingScript paramsPolId =
-  let script = tryCompile prodConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId)
+  let script = tryCompile tracingConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 -- TODO: can we change the signature to just take the param policy id?
 programmableLogicMintingScript :: C.PaymentCredential -> C.StakeCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3
 programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId =
-  let script = tryCompile prodConfig
+  let script = tryCompile tracingConfig
                $ mkProgrammableLogicMinting
                   # pdata (pconstant $ transCredential progLogicBaseSpndingCred)
                   # pdata (pconstant $ transPolicyId nodePolId)
@@ -96,39 +99,39 @@ programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId =
 
 programmableLogicBaseScript :: C.StakeCredential -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the stake cred of the global script
 programmableLogicBaseScript globalCred =
-  let script = tryCompile prodConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred)
+  let script = tryCompile tracingConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 programmableLogicGlobalScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the CS holding protocol params datum
 programmableLogicGlobalScript paramsPolId =
-  let script = tryCompile prodConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId)
+  let script = tryCompile tracingConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 permissionedTransferScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3
 permissionedTransferScript cred =
-  let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred)
+  let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 freezeTransferScript :: C.PaymentCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3
 freezeTransferScript progLogicBaseSpndingCred blacklistPolicyId =
-  let script = tryCompile prodConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId blacklistPolicyId)
+  let script = tryCompile tracingConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId blacklistPolicyId)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 blacklistMintingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3
 blacklistMintingScript cred =
-  let script = tryCompile prodConfig $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred)
+  let script = tryCompile tracingConfig $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 blacklistSpendingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3
 blacklistSpendingScript cred =
-  let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred)
+  let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred)
   in C.PlutusScriptSerialised $ serialiseScript script
 
 {-| 'C.PlutusScript C.PlutusScriptV3' that always succeeds. Can be used for minting, withdrawal, spending, etc.
 -}
 alwaysSucceedsScript :: C.PlutusScript C.PlutusScriptV3
 alwaysSucceedsScript =
-  C.PlutusScriptSerialised $ serialiseScript $ tryCompile prodConfig palwaysSucceed
+  C.PlutusScriptSerialised $ serialiseScript $ tryCompile tracingConfig palwaysSucceed
 
 -- Utilities
 scriptPolicyIdV3 :: C.PlutusScript C.PlutusScriptV3 -> C.PolicyId

src/test/Wst/Test/UnitTest.hs

@@ -5,9 +5,12 @@ module Wst.Test.UnitTest(
 
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
+import Cardano.Ledger.Api qualified as Ledger
 import Cardano.Ledger.Core qualified as Ledger
+import Cardano.Ledger.Plutus.ExUnits qualified as Ledger
 import Cardano.Ledger.Shelley.TxCert qualified as TxCert
-import Control.Lens ((^.))
+import Control.Exception (try)
+import Control.Lens (set, (%~), (&), (^.))
 import Control.Monad (void)
 import Control.Monad.Reader (asks)
 import Control.Monad.Reader.Class (MonadReader)
@@ -16,12 +19,17 @@ import Convex.BuildTx qualified as BuildTx
 import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx),
                      MonadMockchain, MonadUtxoQuery)
 import Convex.CoinSelection (ChangeOutputPosition (TrailingChange))
+import Convex.MockChain
 import Convex.MockChain.CoinSelection (tryBalanceAndSubmit)
+import Convex.MockChain.Defaults qualified as Defaults
 import Convex.MockChain.Utils (mockchainFails, mockchainSucceeds)
+import Convex.NodeParams (NodeParams, ledgerProtocolParameters,
+                          protocolParameters)
 import Convex.Utils (failOnError)
 import Convex.Wallet.MockWallet qualified as Wallet
 import Convex.Wallet.Operator (signTxOperator)
 import Data.List (isPrefixOf)
+import Data.Word (Word32)
 import GHC.Exception (SomeException, throw)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, testCase)
@@ -33,9 +41,28 @@ import Wst.Offchain.Query qualified as Query
 import Wst.Offchain.Scripts qualified as Scripts
 import Wst.Test.Env (admin, asAdmin, asWallet, user)
 
+testTxSize :: Word32
+testTxSize = 16384
+
+testNodeParams :: NodeParams C.ConwayEra
+testNodeParams =
+  -- restrict script bugdet to current value on mainnet
+  let newExUnits = Ledger.ExUnits {Ledger.exUnitsSteps = 10_000_000_000, Ledger.exUnitsMem = 14_000_000}
+      npsTx = Defaults.nodeParams & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL) testTxSize
+  in npsTx & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxExUnitsL) newExUnits
+
+-- | Run the 'Mockchain' action with modified node parameters to allow larger-than-usual
+-- transactions. This is useful for showing debug output from the scripts and fail if there is an error
+mockchainSucceedsWithLargeTx :: MockchainIO C.ConwayEra a -> Assertion
+mockchainSucceedsWithLargeTx action =
+  let params' = testNodeParams & ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL %~ (*10)
+  in try @SomeException (runMockchain0IOWith Wallet.initialUTxOs params' action) >>= \case
+      Right{} -> pure ()
+      Left err -> fail (show err)
+
 tests :: TestTree
 tests = testGroup "unit tests"
-  [ testCase "deploy directory and global params" (mockchainSucceeds deployDirectorySet)
+  [ testCase "deploy directory and global params" (mockchainSucceedsWithLargeTx deployDirectorySet)
   , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode)
   , testGroup "issue programmable tokens"
       [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator)

src/wst-poc.cabal

@@ -162,6 +162,7 @@ test-suite wst-poc-test
   build-depends:
     , base                    >=4.14.0
     , cardano-api
+    , cardano-ledger-api
     , cardano-ledger-core
     , cardano-ledger-shelley
     , convex-base