Fix assertFailedTransactions

IntersectMBO · Jun 24, 2021 · 455c643 · 455c643
1 parent 42a936f
commit 455c643
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 7 deletions.
diff --git a/plutus-contract/src/Wallet/Emulator/Folds.hs b/plutus-contract/src/Wallet/Emulator/Folds.hs
@@ -48,6 +48,7 @@ module Wallet.Emulator.Folds (
     , postMapM
     ) where
 
+import           Control.Applicative                    ((<|>))
 import           Control.Foldl                          (Fold (..), FoldM (..))
 import qualified Control.Foldl                          as L
 import           Control.Lens                           hiding (Empty, Fold)
@@ -80,10 +81,12 @@ import           Plutus.Trace.Emulator.Types            (ContractInstanceLog, Co
                                                          _HandledRequest, cilMessage, cilTag, toInstanceState)
 import           Wallet.Emulator.Chain                  (ChainEvent (..), _TxnValidate, _TxnValidationFail)
 import           Wallet.Emulator.ChainIndex             (_AddressStartWatching)
+import           Wallet.Emulator.LogMessages            (_ValidationFailed)
 import           Wallet.Emulator.MultiAgent             (EmulatorEvent, EmulatorTimeEvent, chainEvent, chainIndexEvent,
-                                                         eteEvent, instanceEvent, userThreadEvent, walletClientEvent)
+                                                         eteEvent, instanceEvent, userThreadEvent, walletClientEvent,
+                                                         walletEvent')
 import           Wallet.Emulator.NodeClient             (_TxSubmit)
-import           Wallet.Emulator.Wallet                 (Wallet, walletAddress)
+import           Wallet.Emulator.Wallet                 (Wallet, _TxBalanceLog, walletAddress)
 import qualified Wallet.Rollup                          as Rollup
 import           Wallet.Rollup.Types                    (AnnotatedTx)
 
@@ -94,8 +97,10 @@ type EmulatorEventFoldM effs a = FoldM (Eff effs) EmulatorEvent a
 
 -- | Transactions that failed to validate, in the given validation phase (if specified).
 failedTransactions :: Maybe ValidationPhase -> EmulatorEventFold [(TxId, Tx, ValidationError, [ScriptValidationEvent])]
-failedTransactions phase = preMapMaybe (preview (eteEvent . chainEvent . _TxnValidationFail) >=> filterPhase phase) L.list
+failedTransactions phase = preMapMaybe (f >=> filterPhase phase) L.list
     where
+        f e = preview (eteEvent . chainEvent . _TxnValidationFail) e
+          <|> preview (eteEvent . walletEvent' . _2 . _TxBalanceLog . _ValidationFailed) e
         filterPhase Nothing (_, i, t, v, e)   = Just (i, t, v, e)
         filterPhase (Just p) (p', i, t, v, e) = if p == p' then Just (i, t, v, e) else Nothing
 

diff --git a/plutus-contract/src/Wallet/Emulator/LogMessages.hs b/plutus-contract/src/Wallet/Emulator/LogMessages.hs
@@ -3,17 +3,21 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TemplateHaskell    #-}
 -- | The log messages produced by the emulator.
 module Wallet.Emulator.LogMessages(
   RequestHandlerLogMsg(..)
   , TxBalanceMsg(..)
+  , _ValidationFailed
   ) where
 
+import           Control.Lens.TH             (makePrisms)
 import           Data.Aeson                  (FromJSON, ToJSON)
-import           Data.Text.Prettyprint.Doc   (Pretty (..), hang, viaShow, vsep, (<+>))
+import           Data.Text.Prettyprint.Doc   (Pretty (..), colon, hang, viaShow, vsep, (<+>))
 import           GHC.Generics                (Generic)
-import           Ledger                      (Address, Tx, txId)
+import           Ledger                      (Address, Tx, TxId, txId)
 import           Ledger.Constraints.OffChain (UnbalancedTx)
+import           Ledger.Index                (ScriptValidationEvent, ValidationError, ValidationPhase)
 import           Ledger.Slot                 (Slot, SlotRange)
 import           Ledger.Value                (Value)
 import           Wallet.Emulator.Error       (WalletAPIError)
@@ -50,6 +54,7 @@ data TxBalanceMsg =
     | AddingCollateralInputsFor Value
     | FinishedBalancing Tx
     | SubmittingTx Tx
+    | ValidationFailed ValidationPhase TxId Tx ValidationError [ScriptValidationEvent]
     deriving stock (Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
@@ -64,3 +69,6 @@ instance Pretty TxBalanceMsg where
         AddingCollateralInputsFor vl -> "Adding collateral inputs for" <+> pretty vl
         FinishedBalancing tx         -> "Finished balancing." <+> pretty (txId tx)
         SubmittingTx tx              -> "Submitting tx:" <+> pretty (txId tx)
+        ValidationFailed p i _ e _   -> "Validation error:" <+> pretty p <+> pretty i <> colon <+> pretty e
+
+makePrisms ''TxBalanceMsg
diff --git a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs
@@ -107,6 +107,9 @@ walletClientEvent w = prism' (ClientEvent w) (\case { ClientEvent w' c | w == w'
 walletEvent :: Wallet.Wallet -> Prism' EmulatorEvent' Wallet.WalletEvent
 walletEvent w = prism' (WalletEvent w) (\case { WalletEvent w' c | w == w' -> Just c; _ -> Nothing })
 
+walletEvent' :: Prism' EmulatorEvent' (Wallet.Wallet, Wallet.WalletEvent)
+walletEvent' = prism' (uncurry WalletEvent) (\case { WalletEvent w c -> Just (w, c); _ -> Nothing })
+
 chainIndexEvent :: Wallet.Wallet -> Prism' EmulatorEvent' ChainIndex.ChainIndexEvent
 chainIndexEvent w = prism' (ChainIndexEvent w) (\case { ChainIndexEvent w' c | w == w' -> Just c; _ -> Nothing })
 

diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs
@@ -19,7 +19,7 @@ import           Control.Lens                   as Lens
 import           Control.Monad                  (foldM)
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Error
-import           Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo)
+import           Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo, logWarn)
 import           Control.Monad.Freer.State
 import           Control.Monad.Freer.TH         (makeEffect)
 import           Control.Newtype.Generics       (Newtype)
@@ -203,7 +203,9 @@ validateTxAndAddFees ownTxOuts utx = do
     signedTx <- handleAddSignature tx
     let utxoIndex        = Ledger.UtxoIndex $ unBalancedTxUtxoIndex utx <> (fmap txOutTxOut ownTxOuts)
         ((e, _), events) = Ledger.runValidation (Ledger.validateTransactionOffChain signedTx) utxoIndex
-    traverse_ (throwError . WAPI.ValidationError . snd) e
+    flip traverse_ e $ \(phase, ve) -> do
+        logWarn $ ValidationFailed phase (txId tx) tx ve events
+        throwError $ WAPI.ValidationError ve
     let scriptsSize = getSum $ foldMap (Sum . scriptSize . Ledger.sveScript) events
         theFee = minFee tx <> Ada.lovelaceValueOf scriptsSize -- TODO: use protocol parameters
     pure $ utx{ unBalancedTxTx = (unBalancedTxTx utx){ txFee = theFee }}