Handle Ogmios AdditionalUtxoOverlap exception

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

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

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

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.

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)

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`

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)"