Add override to submit failing tx to network

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

@@ -0,0 +1,97 @@
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-| Tools for deliberately building a transaction
+with "scriptValidity" flag set to "invalid".
+-}
+module Wst.Offchain.BuildTx.Failing(
+  IsEra,
+  BlacklistedTransferPolicy(..),
+  balanceTxEnvFailing
+) where
+
+import Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra)
+import Cardano.Api.Experimental qualified as C
+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.Monad.Except (MonadError, throwError)
+import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
+import Control.Monad.Trans.Class (MonadTrans (..))
+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.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 Wst.AppError (AppError (..))
+import Wst.Offchain.BuildTx.TransferLogic (FindProofResult (..),
+                                           blacklistInitialNode)
+import Wst.Offchain.Env (HasOperatorEnv (..), OperatorEnv (..))
+import Wst.Offchain.Query (UTxODat (..))
+
+{-| What to do if a transfer cannot proceed because of blacklisting
+-}
+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)
+
+{-| 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 policy btx = do
+  OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv
+  params <- queryProtocolParameters
+  (r, txBuilder) <- BuildTx.runBuildTxT $ btx <* BuildTx.setMinAdaDepositAll params
+  -- TODO: change returnOutputFor to consider the stake address reference
+  -- (needs to be done in sc-tools)
+  let credential = C.PaymentCredentialByKey $ fst bteOperator
+  output <- returnOutputFor credential
+  (balBody, balChanges) <- case r of
+    CredentialNotBlacklisted{} ->
+      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 ->
+        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/BuildTx/TransferLogic.hs

@@ -5,6 +5,7 @@
 
 module Wst.Offchain.BuildTx.TransferLogic
   ( transferSmartTokens,
+    FindProofResult(..),
     issueSmartTokens,
     SeizeReason(..),
     seizeSmartTokens,
@@ -14,6 +15,7 @@ module Wst.Offchain.BuildTx.TransferLogic
     removeBlacklistNode,
     paySmartTokensToDestination,
     registerTransferScripts,
+    blacklistInitialNode
   )
 where
 
@@ -54,7 +56,7 @@ import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..))
 import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (BlacklistNode (..),
                                           DirectorySetNode (..))
-import Wst.AppError (AppError (BlacklistNodeNotFound, DuplicateBlacklistNode, TransferBlacklistedCredential))
+import Wst.AppError (AppError (BlacklistNodeNotFound, DuplicateBlacklistNode))
 import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken,
                                                seizeProgrammableToken,
                                                transferProgrammableToken)
@@ -222,7 +224,7 @@ issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBab
   paySmartTokensToDestination (an, q) issuedPolicyId destinationCred
   pure $ C.AssetId issuedPolicyId an
 
-transferSmartTokens :: forall env era a 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, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m ()
+transferSmartTokens :: forall env era a 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, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m (FindProofResult era)
 transferSmartTokens paramsTxIn blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do
   nid <- queryNetworkId
   userCred <- Env.operatorPaymentCredential
@@ -238,7 +240,7 @@ transferSmartTokens paramsTxIn blacklistNodes directoryList spendingUserOutputs
         C.AdaAssetId -> error "Ada is not programmable"
 
   transferProgrammableToken paramsTxIn txins (transPolicyId programmablePolicyId) directoryList -- Invoking the programmableBase and global scripts
-  addTransferWitness blacklistNodes -- Proof of non-membership of the blacklist
+  result <- addTransferWitness blacklistNodes -- Proof of non-membership of the blacklist
 
   -- Send outputs to destinationCred
   destStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred
@@ -255,6 +257,7 @@ transferSmartTokens paramsTxIn blacklistNodes directoryList spendingUserOutputs
       returnAddr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue srcStakeCred)
       returnOutput = C.TxOut returnAddr returnVal C.TxOutDatumNone C.ReferenceScriptNone
   prependTxOut returnOutput -- Add the seized output to the transaction
+  pure result
 
 {-| Reason for adding an address to the blacklist
 -}
@@ -338,6 +341,7 @@ tryFindProof :: [UTxODat era BlacklistNode] -> Credential -> UTxODat era Blackli
 tryFindProof blacklistNodes cred =
   case findProof blacklistNodes cred of
     CredentialNotBlacklisted r -> r
+    CredentialBlacklisted r -> r
     _ -> error $ "tryFindProof failed for " <> show cred
 
 {-| Find the blacklist node that covers the credential.
@@ -352,18 +356,10 @@ findProof blacklistNodes cred =
       then CredentialBlacklisted node
       else CredentialNotBlacklisted node
 
-{-| Check that the credential is not blacklisted. Throw an error if the
-  credential is blacklisted.
--}
-checkNotBlacklisted :: forall era m. MonadError (AppError era) m => [UTxODat era BlacklistNode] -> Credential -> m ()
-checkNotBlacklisted nodes cred = case findProof nodes cred of
-  CredentialNotBlacklisted{} -> pure ()
-  _ -> throwError (TransferBlacklistedCredential cred)
-
 {-| Add a proof that the user is allowed to transfer programmable tokens.
 Uses the user from 'HasOperatorEnv env'. Fails if the user is blacklisted.
 -}
-addTransferWitness :: forall env era m. (MonadError (AppError era) 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) => [UTxODat era BlacklistNode] -> m ()
+addTransferWitness :: forall env era m. (MonadError (AppError era) 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) => [UTxODat era BlacklistNode] -> m (FindProofResult era)
 addTransferWitness blacklistNodes = Utils.inBabbage @era $ do
   opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) -- In this case 'operator' is the user
   nid <- queryNetworkId
@@ -390,20 +386,20 @@ addTransferWitness blacklistNodes = Utils.inBabbage @era $ do
   -- This means we're traversing the list of blacklist nodes an additional time.
   -- But here is the only place where we can use MonadError. So we have to do it
   -- here to allow the client code to handle the error properly.
-  checkNotBlacklisted blacklistNodes (transCredential $ C.PaymentCredentialByKey opPkh)
+  let proofResult = findProof blacklistNodes (transCredential $ C.PaymentCredentialByKey opPkh)
 
   addRequiredSignature opPkh
   addReferencesWithTxBody witnessReferences
   addWithdrawalWithTxBody -- Add the global script witness to the transaction
     (C.makeStakeAddress nid transferStakeCred)
     (C.Quantity 0)
     $ C.ScriptWitness C.ScriptWitnessForStakeAddr . transferStakeWitness
+  pure proofResult
 
 addReferencesWithTxBody :: (MonadBuildTx era m, C.IsBabbageBasedEra era) => (C.TxBodyContent C.BuildTx era -> [C.TxIn]) -> m ()
 addReferencesWithTxBody f =
   addTxBuilder (TxBuilder $ \body -> over (L.txInsReference . L._TxInsReferenceIso) (nub . (f body <>)))
 
-
 addSeizeWitness :: forall env era 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 ()
 addSeizeWitness = Utils.inBabbage @era $ do
   opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)

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

@@ -30,6 +30,8 @@ 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,
+                                     balanceTxEnvFailing)
 import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx
 import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
 import Wst.Offchain.BuildTx.TransferLogic (BlacklistReason)
@@ -39,7 +41,6 @@ import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
 import Wst.Offchain.Query qualified as Query
 
-
 {-| Build a transaction that deploys the directory and global params. Returns the
 transaction and the 'TxIn' that was selected for the one-shot NFTs.
 -}
@@ -176,17 +177,20 @@ transferSmartTokensTx :: forall era env m.
   , C.IsBabbageBasedEra era
   , C.HasScriptLanguageInEra C.PlutusScriptV3 era
   , MonadUtxoQuery m
+  , IsEra era
   )
-  => C.AssetId -- ^ AssetId to transfer
+  => BlacklistedTransferPolicy
+  -> C.AssetId -- ^ AssetId to transfer
   -> Quantity -- ^ Amount of tokens to be minted
   -> C.PaymentCredential -- ^ Destination credential
   -> m (C.Tx era)
-transferSmartTokensTx assetId quantity destCred = do
+transferSmartTokensTx policy assetId quantity destCred = do
   directory <- Query.registryNodes @era
   blacklist <- Query.blacklistNodes @era
   userOutputsAtProgrammable <- Env.operatorPaymentCredential >>= Query.userProgrammableOutputs
   paramsTxIn <- Query.globalParamsNode @era
-  (tx, _) <- Env.balanceTxEnv_ $ do
+  (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

@@ -33,6 +33,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.Endpoints.Deployment qualified as Endpoints
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (uDatum))
@@ -215,15 +216,17 @@ transferProgrammableTokenEndpoint :: forall era env m.
   , C.IsBabbageBasedEra era
   , C.HasScriptLanguageInEra C.PlutusScriptV3 era
   , MonadUtxoQuery m
+  , IsEra era
   )
   => TransferProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era))
-transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer} = do
+transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer, ttaSubmitFailingTx} = do
   operatorEnv <- Env.loadOperatorEnvFromAddress ttaSender
   dirEnv <- asks Env.directoryEnv
   logic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer)
   assetId <- Env.programmableTokenAssetId dirEnv <$> Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer) <*> pure ttaAssetName
+  let policy = maybe DontSubmitFailingTx (\k -> if k then SubmitFailingTx else DontSubmitFailingTx) ttaSubmitFailingTx
   Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer logic $ do
-    TextEnvelopeJSON <$> Endpoints.transferSmartTokensTx assetId ttaQuantity (paymentCredentialFromAddress ttaRecipient)
+    TextEnvelopeJSON <$> Endpoints.transferSmartTokensTx policy assetId ttaQuantity (paymentCredentialFromAddress ttaRecipient)
 
 addToBlacklistEndpoint :: forall era env m.
   ( MonadReader env m

src/lib/Wst/Server/Types.hs

@@ -136,6 +136,7 @@ data TransferProgrammableTokenArgs =
     , ttaIssuer    :: C.Address C.ShelleyAddr
     , ttaAssetName :: AssetName
     , ttaQuantity  :: Quantity
+    , ttaSubmitFailingTx :: Maybe Bool
     }
     deriving stock (Eq, Show, Generic)
 

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

@@ -31,6 +31,7 @@ import SmartTokens.Core.Scripts (ScriptTarget (Debug, Production))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, testCase)
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..))
+import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy (..))
 import Wst.Offchain.BuildTx.Utils (addConwayStakeCredentialCertificate)
 import Wst.Offchain.Endpoints.Deployment qualified as Endpoints
 import Wst.Offchain.Env (DirectoryScriptRoot)
@@ -56,7 +57,8 @@ scriptTargetTests target =
         , testCase "smart token transfer" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= transferSmartTokens)
         , testCase "blacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= blacklistCredential)
         , testCase "unblacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= unblacklistCredential)
-        , testCase "blacklisted transfer" (mockchainFails blacklistTransfer assertBlacklistedAddressException)
+        , testCase "blacklisted transfer" (mockchainFails (blacklistTransfer DontSubmitFailingTx) assertBlacklistedAddressException)
+        , testCase "blacklisted transfer (failing tx)" (mockchainSucceedsWithTarget target (blacklistTransfer SubmitFailingTx))
         , testCase "seize user output" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= seizeUserOutput)
         , testCase "deploy all" (mockchainSucceedsWithTarget target deployAll)
         ]
@@ -152,7 +154,7 @@ transferSmartTokens scriptRoot = failOnError $ Env.withEnv $ do
   asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do
     opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
 
-    Endpoints.transferSmartTokensTx aid 80 (C.PaymentCredentialByKey userPkh)
+    Endpoints.transferSmartTokensTx DontSubmitFailingTx aid 80 (C.PaymentCredentialByKey userPkh)
       >>= void . sendTx . signTxOperator admin
 
     Query.programmableLogicOutputs @C.ConwayEra
@@ -208,8 +210,8 @@ unblacklistCredential scriptRoot = failOnError $ Env.withEnv $ do
 
   pure paymentCred
 
-blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m ()
-blacklistTransfer = failOnError $ Env.withEnv $ do
+blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => BlacklistedTransferPolicy -> m ()
+blacklistTransfer policy = failOnError $ Env.withEnv $ do
   scriptRoot <- runReaderT deployDirectorySet Production
   userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv)
   let userPaymentCred = C.PaymentCredentialByKey userPkh
@@ -221,7 +223,7 @@ blacklistTransfer = failOnError $ Env.withEnv $ do
 
   opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do
     opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
-    Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh)
+    Endpoints.transferSmartTokensTx policy aid 50 (C.PaymentCredentialByKey userPkh)
       >>= void . sendTx . signTxOperator admin
     pure opPkh
 
@@ -230,7 +232,7 @@ blacklistTransfer = failOnError $ Env.withEnv $ do
   asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ Endpoints.insertBlacklistNodeTx "" userPaymentCred
     >>= void . sendTx . signTxOperator admin
 
-  asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ Endpoints.transferSmartTokensTx aid 30 (C.PaymentCredentialByKey opPkh)
+  asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ Endpoints.transferSmartTokensTx policy aid 30 (C.PaymentCredentialByKey opPkh)
     >>= void . sendTx . signTxOperator (user Wallet.w2)
 
 seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m ()
@@ -244,7 +246,7 @@ seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do
     >>= void . sendTx . signTxOperator admin
 
   asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do
-    Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh)
+    Endpoints.transferSmartTokensTx DontSubmitFailingTx aid 50 (C.PaymentCredentialByKey userPkh)
       >>= void . sendTx . signTxOperator admin
     Query.programmableLogicOutputs @C.ConwayEra
       >>= void . expectN 2 "programmable logic outputs"