From 854a4aa3f058c65987651fd9430bfbbaa041ee01 Mon Sep 17 00:00:00 2001 From: Dzmitry Shuysky Date: Mon, 25 Sep 2023 17:08:57 +0200 Subject: [PATCH] Handle Ogmios AdditionalUtxoOverlap exception --- examples/AdditionalUtxos.purs | 15 +++--- examples/ByUrl.purs | 2 +- src/Internal/BalanceTx/Error.purs | 4 +- src/Internal/BalanceTx/ExUnitsAndMinFee.purs | 52 +++++++++++--------- src/Internal/Contract/QueryHandle.purs | 3 +- src/Internal/QueryM/Ogmios.purs | 28 +++++++++-- test/Plutip/Contract.purs | 12 ++++- 7 files changed, 79 insertions(+), 37 deletions(-) diff --git a/examples/AdditionalUtxos.purs b/examples/AdditionalUtxos.purs index e57d746e1..eff0265ca 100644 --- a/examples/AdditionalUtxos.purs +++ b/examples/AdditionalUtxos.purs @@ -50,20 +50,22 @@ main :: Effect Unit main = example testnetNamiConfig example :: ContractParams -> Effect Unit -example contractParams = launchAff_ $ runContract contractParams contract +example contractParams = + launchAff_ $ runContract contractParams $ contract false -contract :: Contract Unit -contract = withoutSync do +contract :: Boolean -> Contract Unit +contract testAdditionalUtxoOverlap = withoutSync do logInfo' "Running Examples.AdditionalUtxos" validator <- alwaysSucceedsScriptV2 let vhash = validatorHash validator - { additionalUtxos, datum } <- payToValidator vhash + { additionalUtxos, datum } <- payToValidator vhash testAdditionalUtxoOverlap spendFromValidator validator additionalUtxos datum payToValidator :: ValidatorHash + -> Boolean -> Contract { additionalUtxos :: UtxoMap, datum :: Datum } -payToValidator vhash = do +payToValidator vhash testAdditionalUtxoOverlap = do scriptRef <- liftEffect (NativeScriptRef <$> randomSampleOne arbitrary) let value :: Value @@ -85,7 +87,8 @@ payToValidator vhash = do unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints balancedTx <- liftedE $ balanceTx unbalancedTx balancedSignedTx <- signTransaction balancedTx - void $ submit balancedSignedTx + txHash <- submit balancedSignedTx + when testAdditionalUtxoOverlap $ awaitTxConfirmed txHash logInfo' "Successfully locked two outputs at the validator address." additionalUtxos <- createAdditionalUtxos balancedSignedTx diff --git a/examples/ByUrl.purs b/examples/ByUrl.purs index 82abbb8da..8f00edce0 100644 --- a/examples/ByUrl.purs +++ b/examples/ByUrl.purs @@ -193,7 +193,7 @@ mkBlockfrostPreprodConfig apiKey = examples :: Map E2ETestName (Contract Unit) examples = Map.fromFoldable - [ "AdditionalUtxos" /\ AdditionalUtxos.contract + [ "AdditionalUtxos" /\ AdditionalUtxos.contract false , "AlwaysMints" /\ AlwaysMints.contract , "NativeScriptMints" /\ NativeScriptMints.contract , "AlwaysSucceeds" /\ AlwaysSucceeds.contract diff --git a/src/Internal/BalanceTx/Error.purs b/src/Internal/BalanceTx/Error.purs index d4678387f..d2ebd8429 100644 --- a/src/Internal/BalanceTx/Error.purs +++ b/src/Internal/BalanceTx/Error.purs @@ -45,7 +45,7 @@ import Ctl.Internal.QueryM.Ogmios , IllFormedExecutionBudget , NoCostModelForLanguage ) - , TxEvaluationFailure(UnparsedError, ScriptFailures) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) ) as Ogmios import Ctl.Internal.Types.Natural (toBigInt) as Natural import Ctl.Internal.Types.Transaction (TransactionInput) @@ -173,6 +173,8 @@ printTxEvaluationFailure printTxEvaluationFailure transaction e = runPrettyString $ case e of Ogmios.UnparsedError error -> line $ "Unknown error: " <> error + Ogmios.AdditionalUtxoOverlap utxos -> + line $ "AdditionalUtxoOverlap: " <> show utxos Ogmios.ScriptFailures sf -> line "Script failures:" <> bullet (foldMapWithIndex printScriptFailures sf) where diff --git a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs index ade5c9ac3..964ddc89e 100644 --- a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs +++ b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs @@ -45,6 +45,7 @@ import Ctl.Internal.Contract.Monad (getQueryHandle) import Ctl.Internal.Plutus.Conversion (fromPlutusUtxoMap) import Ctl.Internal.QueryM.Ogmios ( AdditionalUtxoSet + , TxEvaluationFailure(AdditionalUtxoOverlap) , TxEvaluationResult(TxEvaluationResult) ) as Ogmios import Ctl.Internal.QueryM.Ogmios (TxEvaluationFailure(UnparsedError)) @@ -58,14 +59,14 @@ import Ctl.Internal.Types.Natural (toBigInt) as Natural import Ctl.Internal.Types.Scripts (Language, PlutusScript) import Ctl.Internal.Types.Transaction (TransactionInput) import Data.Array (catMaybes) -import Data.Array (fromFoldable) as Array +import Data.Array (fromFoldable, notElem) as Array import Data.Bifunctor (bimap) import Data.BigInt (BigInt) import Data.Either (Either(Left, Right), note) import Data.Foldable (foldMap) import Data.Lens.Getter ((^.)) import Data.Lens.Setter ((?~)) -import Data.Map (empty, fromFoldable, lookup, toUnfoldable) as Map +import Data.Map (empty, filterKeys, fromFoldable, lookup, toUnfoldable) as Map import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.Newtype (unwrap, wrap) import Data.Set (Set) @@ -80,28 +81,33 @@ evalTxExecutionUnits :: Transaction -> BalanceTxM Ogmios.TxEvaluationResult evalTxExecutionUnits tx = do - queryHandle <- liftContract getQueryHandle - additionalUtxos <- getOgmiosAdditionalUtxoSet - evalResult <- - unwrap <$> liftContract - (liftAff $ queryHandle.evaluateTx tx additionalUtxos) - - case evalResult of - Right a -> pure a - Left evalFailure | tx ^. _isValid -> - throwError $ ExUnitsEvaluationFailed tx evalFailure - Left _ -> pure $ wrap Map.empty + networkId <- askNetworkId + additionalUtxos <- + fromPlutusUtxoMap networkId <$> asksConstraints Constraints._additionalUtxos + worker additionalUtxos where - getOgmiosAdditionalUtxoSet :: BalanceTxM Ogmios.AdditionalUtxoSet - getOgmiosAdditionalUtxoSet = do - networkId <- askNetworkId - additionalUtxos <- - asksConstraints Constraints._additionalUtxos - <#> fromPlutusUtxoMap networkId - pure $ wrap $ Map.fromFoldable - ( bimap transactionInputToTxOutRef transactionOutputToOgmiosTxOut - <$> (Map.toUnfoldable :: _ -> Array _) additionalUtxos - ) + worker :: UtxoMap -> BalanceTxM Ogmios.TxEvaluationResult + worker additionalUtxos = do + queryHandle <- liftContract getQueryHandle + evalResult <- + unwrap <$> liftContract + (liftAff $ queryHandle.evaluateTx tx ogmiosAdditionalUtxos) + case evalResult of + Right a -> pure a + Left (Ogmios.AdditionalUtxoOverlap overlappingUtxos) -> + -- Remove overlapping additional utxos and retry evaluation: + worker $ Map.filterKeys (flip Array.notElem overlappingUtxos) + additionalUtxos + Left evalFailure | tx ^. _isValid -> + throwError $ ExUnitsEvaluationFailed tx evalFailure + Left _ -> pure $ wrap Map.empty + where + ogmiosAdditionalUtxos :: Ogmios.AdditionalUtxoSet + ogmiosAdditionalUtxos = + wrap $ Map.fromFoldable + ( bimap transactionInputToTxOutRef transactionOutputToOgmiosTxOut + <$> (Map.toUnfoldable :: _ -> Array _) additionalUtxos + ) -- Calculates the execution units needed for each script in the transaction -- and the minimum fee, including the script fees. diff --git a/src/Internal/Contract/QueryHandle.purs b/src/Internal/Contract/QueryHandle.purs index 1e42dfd41..5531fe5ae 100644 --- a/src/Internal/Contract/QueryHandle.purs +++ b/src/Internal/Contract/QueryHandle.purs @@ -6,7 +6,7 @@ module Ctl.Internal.Contract.QueryHandle import Prelude -import Contract.Log (logDebug', logWarn') +import Contract.Log (logDebug') import Control.Monad.Error.Class (throwError) import Ctl.Internal.Contract.LogParams (LogParams) import Ctl.Internal.Contract.QueryBackend (BlockfrostBackend, CtlBackend) @@ -40,7 +40,6 @@ import Ctl.Internal.Service.Blockfrost import Ctl.Internal.Service.Blockfrost as Blockfrost import Ctl.Internal.Service.Error (ClientError(ClientOtherError)) import Data.Either (Either(Left, Right)) -import Data.Map as Map import Data.Maybe (fromMaybe, isJust) import Data.Newtype (unwrap, wrap) import Effect.Aff (Aff) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 89e4f338c..188953674 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -38,7 +38,7 @@ module Ctl.Internal.QueryM.Ogmios , OgmiosTxIn , OgmiosTxId , SubmitTxR(SubmitTxSuccess, SubmitFail) - , TxEvaluationFailure(UnparsedError, ScriptFailures) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) , TxEvaluationResult(TxEvaluationResult) , TxEvaluationR(TxEvaluationR) , PoolIdsR @@ -180,6 +180,7 @@ import Ctl.Internal.Types.SystemStart , sysStartToOgmiosTimestamp ) import Ctl.Internal.Types.TokenName (TokenName, getTokenName, mkTokenName) +import Ctl.Internal.Types.Transaction (TransactionInput) import Ctl.Internal.Types.VRFKeyHash (VRFKeyHash(VRFKeyHash)) import Data.Array (catMaybes, index) import Data.Array (head, length, replicate) as Array @@ -768,11 +769,11 @@ instance Show ScriptFailure where -- The following cases are fine to fall through into unparsed error: -- IncompatibleEra --- AdditionalUtxoOverlap -- NotEnoughSynced -- CannotCreateEvaluationContext data TxEvaluationFailure = UnparsedError String + | AdditionalUtxoOverlap (Array TransactionInput) | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) derive instance Generic TxEvaluationFailure _ @@ -852,7 +853,7 @@ instance DecodeAeson TxEvaluationFailure where decodeAeson = aesonObject $ runReaderT cases where cases :: ObjectParser TxEvaluationFailure - cases = decodeScriptFailures <|> defaultCase + cases = decodeScriptFailures <|> decodeAdditionalUtxoOverlap <|> defaultCase defaultCase :: ObjectParser TxEvaluationFailure defaultCase = ReaderT \o -> @@ -868,6 +869,27 @@ instance DecodeAeson TxEvaluationFailure where (_ /\ v') <$> decodeRedeemerPointer k pure $ ScriptFailures scriptFailures + decodeAdditionalUtxoOverlap :: ObjectParser TxEvaluationFailure + decodeAdditionalUtxoOverlap = ReaderT \o -> do + ogmiosOrefs <- + flip getField "AdditionalUtxoOverlap" =<< getField o "EvaluationFailure" + orefs <- + note orefConversionError $ + traverse ogmiosOrefToTransactionInput ogmiosOrefs + pure $ AdditionalUtxoOverlap orefs + where + orefConversionError :: JsonDecodeError + orefConversionError = + TypeMismatch "Could not convert OgmiosTxOutRef to TransactionInput" + + ogmiosOrefToTransactionInput :: OgmiosTxOutRef -> Maybe TransactionInput + ogmiosOrefToTransactionInput { txId, index } = + hexToByteArray txId <#> \transactionId -> + wrap + { transactionId: wrap transactionId + , index + } + ---------------- PROTOCOL PARAMETERS QUERY RESPONSE & PARSING -- | A version of `Rational` with Aeson instance that decodes from `x/y` diff --git a/test/Plutip/Contract.purs b/test/Plutip/Contract.purs index 446f76896..0f362876e 100644 --- a/test/Plutip/Contract.purs +++ b/test/Plutip/Contract.purs @@ -1044,7 +1044,17 @@ suite = do , BigInt.fromInt 50_000_000 ] withWallets distribution \alice -> - withKeyWallet alice AdditionalUtxos.contract + withKeyWallet alice $ AdditionalUtxos.contract false + + test "Handles AdditionalUtxoOverlap exception (AdditionalUtxos example)" do + let + distribution :: InitialUTxOs + distribution = + [ BigInt.fromInt 10_000_000 + , BigInt.fromInt 50_000_000 + ] + withWallets distribution \alice -> + withKeyWallet alice $ AdditionalUtxos.contract true test "Locking & unlocking on an always succeeding script (AlwaysSucceeds example)"