More progress on submitting invalid transaction

cabal.project

@@ -41,9 +41,8 @@ source-repository-package
 
 source-repository-package
   type: git
-  -- location: https://github.com/j-mueller/sc-tools
-  location: https://github.com/amirmrad/sc-tools
-  tag: 6c63efe07015e87719d77fa3fabfe07f959c7227
+  location: https://github.com/j-mueller/sc-tools
+  tag: a3662e093f40082dd6fa525bb0640a10caa1bd70
   subdir:
     src/devnet
     src/blockfrost

frontend/src/app/[username]/index.tsx

@@ -74,9 +74,10 @@ export default function Profile() {
           },
         }
       );
-      console.log('Send response:', response.data);
+      const isValid = !(getUserAccountDetails()?.status === 'Frozen');
+      console.log('Send response:', response.data, isValid);
       const tx = await lucid.fromTx(response.data.cborHex);
-      const txId = await signAndSentTx(lucid, tx);
+      const txId = await signAndSentTx(lucid, tx, isValid);
       await updateAccountBalance(sendRecipientAddress);
       await updateAccountBalance(accountInfo.address);
       changeAlertInfo({severity: 'success', message: 'Transaction sent successfully!', open: true, link: `https://preview.cexplorer.io/tx/${txId}`});

frontend/src/app/utils/walletUtils.ts

@@ -1,5 +1,5 @@
 //Axios imports
-import axios from 'axios';
+import axios, { AxiosResponse } from 'axios';
 
 //Lucis imports
 import { Address, Assets, Blockfrost, CML, credentialToAddress, Lucid, LucidEvolution, makeTxSignBuilder, paymentCredentialOf, toUnit, TxSignBuilder, Unit, valueToAssets, walletFromSeed } from "@lucid-evolution/lucid";
@@ -85,22 +85,42 @@ export async function getBlacklist(){
   }
 }
 
-export async function signAndSentTx(lucid: LucidEvolution, tx: TxSignBuilder): Promise<string> {
+export async function submitTx(tx: string): Promise<AxiosResponse<any, any>> {
+  return axios.post(
+      '/api/v1/tx/submit',
+      {
+        description: "",
+        type: "Tx ConwayEra",
+        cborHex: tx
+      },
+      {
+        headers: {
+          'Content-Type': 'application/json;charset=utf-8', 
+        },
+      }
+    );
+  }
+
+export async function signAndSentTx(lucid: LucidEvolution, tx: TxSignBuilder, isValid: boolean = true): Promise<string> {
+  console.log("tx.toTransaction().isValid()", tx.toTransaction().is_valid());
   const txBuilder = await makeTxSignBuilder(lucid.wallet(), tx.toTransaction()).complete();
+  console.log("txBuilder.toTransaction().isValid()", txBuilder.toTransaction().is_valid())
   const cmlTx = txBuilder.toTransaction();
   const witnessSet = txBuilder.toTransaction().witness_set();
   const expectedScriptDataHash : CML.ScriptDataHash | undefined = CML.calc_script_data_hash(witnessSet.redeemers()!, CML.PlutusDataList.new(), lucid.config().costModels!, witnessSet.languages());
-  // console.log('Calculated Script Data Hash:', expectedScriptDataHash?.to_hex());
   const cmlTxBodyClone = CML.TransactionBody.from_cbor_hex(cmlTx!.body().to_cbor_hex());
   // console.log('Preclone script hash:', cmlTxBodyClone.script_data_hash()?.to_hex());
   cmlTxBodyClone.set_script_data_hash(expectedScriptDataHash!);
   // console.log('Postclone script hash:', cmlTxBodyClone.script_data_hash()?.to_hex());
-  const cmlClonedTx = CML.Transaction.new(cmlTxBodyClone, cmlTx!.witness_set(), true, cmlTx!.auxiliary_data());
+  const cmlClonedTx = CML.Transaction.new(cmlTxBodyClone, cmlTx!.witness_set(), isValid, cmlTx!.auxiliary_data());
   const cmlClonedSignedTx = await makeTxSignBuilder(lucid.wallet(), cmlClonedTx).sign.withWallet().complete();
-  const txId = await cmlClonedSignedTx.submit();
-  await lucid.awaitTx(txId);
-  console.log(cmlClonedSignedTx);
-  return txId
+  // const txId = await cmlClonedSignedTx.submit();
+  const txId = await submitTx(cmlClonedSignedTx.toCBOR());
+  const i = txId.data;
+  console.log(txId);
+  await lucid.awaitTx(txId.data);
+  // console.log(cmlClonedSignedTx);
+  return i
 }
 
 export type WalletType = "Lace" | "Eternl" | "Nami" | "Yoroi";

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

@@ -11,30 +11,25 @@ module Wst.Offchain.BuildTx.Failing(
   balanceTxEnvFailing
 ) where
 
-import Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra)
-import Cardano.Api.Experimental qualified as C
+import Cardano.Api.Experimental (IsEra)
 import Cardano.Api.Shelley qualified as C
-import Cardano.Ledger.Api qualified as L
-import Control.Lens (Iso', _3, _Just, at, iso, set, (&), (.~))
+import Control.Lens (set)
 import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
-import Control.Monad.Trans.Class (MonadTrans (..))
+import Control.Monad.Reader (MonadReader, asks)
 import Convex.BuildTx (BuildTxT)
 import Convex.BuildTx qualified as BuildTx
 import Convex.CardanoApi.Lenses qualified as L
-import Convex.Class (MonadBlockchain (utxoByTxIn), queryProtocolParameters)
+import Convex.Class (MonadBlockchain, queryProtocolParameters)
 import Convex.CoinSelection qualified as CoinSelection
 import Convex.PlutusLedger.V1 (transCredential)
-import Convex.Scripts (toHashableScriptData)
 import Convex.Utils (mapError)
 import Convex.Utxos (BalanceChanges)
 import Convex.Utxos qualified as Utxos
 import Convex.Wallet.Operator (returnOutputFor)
-import Data.Bifunctor (Bifunctor (..))
-import Data.Map (Map)
+import Data.Aeson (FromJSON, ToJSON)
+import GHC.Generics (Generic)
 import Wst.AppError (AppError (..))
-import Wst.Offchain.BuildTx.TransferLogic (FindProofResult (..),
-                                           blacklistInitialNode)
+import Wst.Offchain.BuildTx.TransferLogic (FindProofResult (..))
 import Wst.Offchain.Env (HasOperatorEnv (..), OperatorEnv (..))
 import Wst.Offchain.Query (UTxODat (..))
 
@@ -43,11 +38,12 @@ import Wst.Offchain.Query (UTxODat (..))
 data BlacklistedTransferPolicy
   = SubmitFailingTx -- ^ Deliberately submit a transaction with "scriptValidity = False". This will result in the collateral input being spent!
   | DontSubmitFailingTx -- ^ Don't submit a transaction
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
 
 {-| Balance a transaction using the operator's funds and return output
 -}
-balanceTxEnvFailing :: forall era env m. (IsEra era, MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BlacklistedTransferPolicy -> BuildTxT era m (FindProofResult era) -> m (C.BalancedTxBody era, BalanceChanges)
+balanceTxEnvFailing :: forall era env m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BlacklistedTransferPolicy -> BuildTxT era m (FindProofResult era) -> m (C.BalancedTxBody era, BalanceChanges)
 balanceTxEnvFailing policy btx = do
   OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv
   params <- queryProtocolParameters
@@ -57,41 +53,15 @@ balanceTxEnvFailing policy btx = do
   let credential = C.PaymentCredentialByKey $ fst bteOperator
   output <- returnOutputFor credential
   (balBody, balChanges) <- case r of
-    CredentialNotBlacklisted{} ->
+    CredentialNotBlacklisted{} -> do
       mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange)
-    CredentialBlacklisted UTxODat{uIn}
-      | policy == SubmitFailingTx ->
-        fmap (first setScriptsInvalid)
-          $ runBacklistResetT uIn
-          $ mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange)
-      | otherwise ->
+    CredentialBlacklisted UTxODat{}
+      | policy == SubmitFailingTx -> do
+        -- deliberately set the script validity flag to false
+        -- this means we will be losing the collateral!
+        let builder' = txBuilder <> BuildTx.liftTxBodyEndo (set L.txScriptValidity (C.TxScriptValidity C.alonzoBasedEra C.ScriptInvalid))
+        mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) builder' CoinSelection.TrailingChange)
+      | otherwise -> do
         throwError (TransferBlacklistedCredential (transCredential credential))
     NoBlacklistNodes -> throwError BlacklistNodeNotFound
   pure (balBody, balChanges)
-
-newtype BlacklistResetT m a = BlacklistResetT (ReaderT C.TxIn m a)
-  deriving newtype (Functor, Applicative, Monad, MonadError e, MonadTrans)
-
-instance (C.IsBabbageBasedEra era, MonadBlockchain era m) => MonadBlockchain era (BlacklistResetT m) where
-  utxoByTxIn txis = BlacklistResetT $ do
-    txi <- ask
-    let newDat = C.TxOutDatumInline C.babbageBasedEra (toHashableScriptData blacklistInitialNode)
-    fmap (set (_UTxO . at txi . _Just . L._TxOut . _3) newDat) $ utxoByTxIn txis
-
-runBacklistResetT :: C.TxIn -> BlacklistResetT m a -> m a
-runBacklistResetT txi (BlacklistResetT action) = runReaderT action txi
-
-_UTxO :: Iso' (C.UTxO era) (Map C.TxIn (C.TxOut C.CtxUTxO era))
-_UTxO = iso t f where
-  t (C.UTxO k) = k
-  f = C.UTxO
-
-setScriptsInvalid ::
-  forall era.
-  ( IsEra era
-  )
-  => C.BalancedTxBody era
-  -> C.BalancedTxBody era
-setScriptsInvalid (C.BalancedTxBody a (C.UnsignedTx b) c d) = obtainCommonConstraints (useEra @era) $
-  let b' = C.UnsignedTx (b & L.isValidTxL @(C.LedgerEra era) .~ L.IsValid False)
-  in C.BalancedTxBody a b' c d

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

@@ -30,7 +30,7 @@ import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.AppError (AppError (NoTokensToSeize))
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey))
 import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx
-import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy, IsEra,
+import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy,
                                      balanceTxEnvFailing)
 import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx
 import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
@@ -177,7 +177,6 @@ transferSmartTokensTx :: forall era env m.
   , C.IsBabbageBasedEra era
   , C.HasScriptLanguageInEra C.PlutusScriptV3 era
   , MonadUtxoQuery m
-  , IsEra era
   )
   => BlacklistedTransferPolicy
   -> C.AssetId -- ^ AssetId to transfer
@@ -190,7 +189,6 @@ transferSmartTokensTx policy assetId quantity destCred = do
   userOutputsAtProgrammable <- Env.operatorPaymentCredential >>= Query.userProgrammableOutputs
   paramsTxIn <- Query.globalParamsNode @era
   (tx, _) <- balanceTxEnvFailing policy $ do
-    -- TODO: use a different balancing mechanism if we expect the scripts to fail
     BuildTx.transferSmartTokens paramsTxIn blacklist directory userOutputsAtProgrammable (assetId, quantity) destCred
   pure (Convex.CoinSelection.signBalancedTxBody [] tx)
 

src/lib/Wst/Server.hs

@@ -12,6 +12,8 @@ module Wst.Server(
   defaultServerArgs
   ) where
 
+import Blammo.Logging.Simple (HasLogger, Message ((:#)), MonadLogger, logInfo,
+                              (.=))
 import Blockfrost.Client.Types qualified as Blockfrost
 import Cardano.Api.Shelley qualified as C
 import Control.Lens qualified as L
@@ -20,6 +22,7 @@ import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Reader (MonadReader, asks)
 import Convex.CardanoApi.Lenses qualified as L
 import Convex.Class (MonadBlockchain (sendTx), MonadUtxoQuery)
+import Data.Aeson.Types (KeyValue)
 import Data.Data (Proxy (..))
 import Data.List (nub)
 import Network.Wai.Handler.Warp qualified as Warp
@@ -33,7 +36,7 @@ import SmartTokens.Types.PTokenDirectory (blnKey)
 import System.Environment qualified
 import Wst.App (WstApp, runWstAppServant)
 import Wst.AppError (AppError (..))
-import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy (..), IsEra)
+import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy (..))
 import Wst.Offchain.Endpoints.Deployment qualified as Endpoints
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (uDatum))
@@ -77,7 +80,7 @@ defaultServerArgs =
     , saStaticFiles = Nothing
     }
 
-runServer :: (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> ServerArgs -> IO ()
+runServer :: (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env, HasLogger env) => env -> ServerArgs -> IO ()
 runServer env ServerArgs{saPort, saStaticFiles} = do
   let bf   = Blockfrost.projectId $ Env.envBlockfrost $ Env.runtimeEnv env
       app  = cors (const $ Just simpleCorsResourcePolicy)
@@ -87,7 +90,7 @@ runServer env ServerArgs{saPort, saStaticFiles} = do
       port = saPort
   Warp.run port app
 
-server :: forall env. (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> Server APIInEra
+server :: forall env. (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env, HasLogger env) => env -> Server APIInEra
 server env = hoistServer (Proxy @APIInEra) (runWstAppServant env) $
   healthcheck
   :<|> queryApi @env
@@ -104,7 +107,7 @@ queryApi =
   :<|> queryAllFunds @C.ConwayEra @env (Proxy @C.ConwayEra)
   :<|> computeUserAddress (Proxy @C.ConwayEra)
 
-txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra)
+txApi :: forall env. (Env.HasDirectoryEnv env, HasLogger env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra)
 txApi =
   (issueProgrammableTokenEndpoint @C.ConwayEra @env
   :<|> transferProgrammableTokenEndpoint @C.ConwayEra @env
@@ -216,7 +219,7 @@ transferProgrammableTokenEndpoint :: forall era env m.
   , C.IsBabbageBasedEra era
   , C.HasScriptLanguageInEra C.PlutusScriptV3 era
   , MonadUtxoQuery m
-  , IsEra era
+  , MonadLogger m
   )
   => TransferProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era))
 transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer, ttaSubmitFailingTx} = do
@@ -225,6 +228,7 @@ transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRe
   logic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer)
   assetId <- Env.programmableTokenAssetId dirEnv <$> Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer) <*> pure ttaAssetName
   let policy = if ttaSubmitFailingTx then SubmitFailingTx else DontSubmitFailingTx
+  logInfo $ "Transfer programmable tokens" :# [logPolicy policy, logSender ttaSender, logRecipient ttaRecipient]
   Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer logic $ do
     TextEnvelopeJSON <$> Endpoints.transferSmartTokensTx policy assetId ttaQuantity (paymentCredentialFromAddress ttaRecipient)
 
@@ -296,3 +300,14 @@ submitTxEndpoint :: forall era m.
   =>  TextEnvelopeJSON (C.Tx era) -> m C.TxId
 submitTxEndpoint (TextEnvelopeJSON tx) = do
   either (throwError . SubmitError) pure =<< sendTx tx
+
+-- structured Logging
+
+logPolicy :: (KeyValue e kv) => BlacklistedTransferPolicy -> kv
+logPolicy p = "policy" .= p
+
+logSender :: (KeyValue e kv) => C.Address C.ShelleyAddr -> kv
+logSender p = "sender" .= p
+
+logRecipient :: (KeyValue e kv) => C.Address C.ShelleyAddr -> kv
+logRecipient p = "recipient" .= p

src/test/unit/Wst/Test/UnitTest.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Wst.Test.UnitTest(
   tests
@@ -9,10 +10,11 @@ import Cardano.Ledger.Api qualified as Ledger
 import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
 import Control.Lens ((%~), (&), (^.))
 import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks)
 import Convex.BuildTx qualified as BuildTx
 import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx),
-                     MonadMockchain, MonadUtxoQuery)
+                     MonadMockchain, MonadUtxoQuery, ValidationError, getTxById)
 import Convex.CoinSelection (ChangeOutputPosition (TrailingChange))
 import Convex.MockChain (MockchainT)
 import Convex.MockChain.CoinSelection (tryBalanceAndSubmit)
@@ -29,7 +31,7 @@ import Data.String (IsString (..))
 import GHC.Exception (SomeException, throw)
 import SmartTokens.Core.Scripts (ScriptTarget (Debug, Production))
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (Assertion, testCase)
+import Test.Tasty.HUnit (Assertion, assertEqual, testCase)
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..))
 import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy (..))
 import Wst.Offchain.BuildTx.Utils (addConwayStakeCredentialCertificate)
@@ -58,7 +60,7 @@ scriptTargetTests target =
         , testCase "blacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= blacklistCredential)
         , testCase "unblacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= unblacklistCredential)
         , testCase "blacklisted transfer" (mockchainFails (blacklistTransfer DontSubmitFailingTx) assertBlacklistedAddressException)
-        , testCase "blacklisted transfer (failing tx)" (mockchainSucceedsWithTarget target (blacklistTransfer SubmitFailingTx))
+        , testCase "blacklisted transfer (failing tx)" (mockchainSucceedsWithTarget target (blacklistTransfer SubmitFailingTx >>= assertFailingTx))
         , testCase "seize user output" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= seizeUserOutput)
         , testCase "deploy all" (mockchainSucceedsWithTarget target deployAll)
         ]
@@ -210,7 +212,7 @@ unblacklistCredential scriptRoot = failOnError $ Env.withEnv $ do
 
   pure paymentCred
 
-blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => BlacklistedTransferPolicy -> m ()
+blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => BlacklistedTransferPolicy -> m (Either (ValidationError C.ConwayEra) C.TxId)
 blacklistTransfer policy = failOnError $ Env.withEnv $ do
   scriptRoot <- runReaderT deployDirectorySet Production
   userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv)
@@ -233,7 +235,7 @@ blacklistTransfer policy = failOnError $ Env.withEnv $ do
     >>= void . sendTx . signTxOperator admin
 
   asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ Endpoints.transferSmartTokensTx policy aid 30 (C.PaymentCredentialByKey opPkh)
-    >>= void . sendTx . signTxOperator (user Wallet.w2)
+    >>= sendTx . signTxOperator (user Wallet.w2)
 
 seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m ()
 seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do
@@ -352,3 +354,13 @@ nodeParamsFor = \case
 mockchainSucceedsWithTarget :: ScriptTarget -> ReaderT ScriptTarget (MockchainT C.ConwayEra IO) a -> Assertion
 mockchainSucceedsWithTarget target =
   mockchainSucceedsWith (nodeParamsFor target) . flip runReaderT target
+
+{-| Assert that the transaction exists on the mockchain and that its script validity flag
+is set to 'C.ScriptInvalid'
+-}
+assertFailingTx :: (MonadMockchain era m, C.IsAlonzoBasedEra era, MonadFail m, MonadIO m) => Either (ValidationError era) C.TxId -> m ()
+assertFailingTx = \case
+  Left err  -> fail $ "Expected TxId, got: " <> show err
+  Right txId -> do
+    C.TxBody C.TxBodyContent{C.txScriptValidity} <- getTxById txId >>= maybe (fail $ "Tx not found: " <> show txId) (pure . C.getTxBody)
+    liftIO (assertEqual "Tx validity" (C.TxScriptValidity C.alonzoBasedEra C.ScriptInvalid) txScriptValidity)

src/wst-poc.cabal

@@ -101,7 +101,6 @@ library
     , blockfrost-client
     , blockfrost-client-core
     , cardano-api
-    , cardano-ledger-api
     , cardano-ledger-shelley
     , containers
     , convex-base
@@ -125,7 +124,6 @@ library
     , servant-client-core
     , servant-server
     , text
-    , transformers
     , wai-cors
     , warp