Merge pull request #4484 from input-output-hk/jordan/4479-bug

Update error message for incorrectly witnessed collateral inputs
IntersectMBO · Sep 29, 2022 · 23b855d · 23b855d
2 parents 72d5ba3 + d100008
commit 23b855d
Show file tree

Hide file tree

Showing 3 changed files with 38 additions and 17 deletions.
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -694,7 +694,7 @@ module Cardano.Api (
     getIsCardanoEraConstraint,
 
     -- ** Misc
-    NotScriptLockedTxInsError(..),
+    ScriptLockedTxInsError(..),
     TxInsExistError(..),
     renderNotScriptLockedTxInsError,
     renderTxInsExistError,

diff --git a/cardano-api/src/Cardano/Api/Convenience/Construction.hs b/cardano-api/src/Cardano/Api/Convenience/Construction.hs
@@ -5,7 +5,7 @@ module Cardano.Api.Convenience.Construction (
 
     -- * Misc
     TxInsExistError(..),
-    NotScriptLockedTxInsError(..),
+    ScriptLockedTxInsError(..),
     notScriptLockedTxIns,
     renderNotScriptLockedTxInsError,
     renderTxInsExistError,
@@ -84,19 +84,20 @@ txInsExistInUTxO ins (UTxO utxo)
       then return ()
       else Left . TxInsDoNotExist $ ins List.\\ occursInUtxo
 
-newtype NotScriptLockedTxInsError = NotScriptLockedTxIns [TxIn]
+newtype ScriptLockedTxInsError = ScriptLockedTxIns [TxIn]
 
-renderNotScriptLockedTxInsError :: NotScriptLockedTxInsError -> Text
-renderNotScriptLockedTxInsError (NotScriptLockedTxIns txins) =
-  "The followings tx inputs are not script locked: " <> textShow (map renderTxIn txins)
+renderNotScriptLockedTxInsError :: ScriptLockedTxInsError -> Text
+renderNotScriptLockedTxInsError (ScriptLockedTxIns txins) =
+  "The followings tx inputs were expected to be key witnessed but are actually script witnessed: " <>
+  textShow (map renderTxIn txins)
 
-notScriptLockedTxIns :: [TxIn] -> UTxO era -> Either NotScriptLockedTxInsError ()
+notScriptLockedTxIns :: [TxIn] -> UTxO era -> Either ScriptLockedTxInsError ()
 notScriptLockedTxIns collTxIns (UTxO utxo) = do
   let onlyCollateralUTxOs = Map.restrictKeys utxo $ Set.fromList collTxIns
       scriptLockedTxIns =
         filter (\(_, TxOut aInEra _ _ _) -> not $ isKeyAddress aInEra ) $ Map.assocs onlyCollateralUTxOs
   if null scriptLockedTxIns
   then return ()
-  else Left . NotScriptLockedTxIns $ map fst scriptLockedTxIns
+  else Left . ScriptLockedTxIns $ map fst scriptLockedTxIns
 
 
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs
@@ -111,7 +111,7 @@ data ShelleyTxCmdError
   | ShelleyTxCmdPParamExecutionUnitsNotAvailable
   | ShelleyTxCmdTxEraCastErr EraCastError
   | ShelleyTxCmdQueryConvenienceError !QueryConvenienceError
-  | ShelleyTxCmdQueryNotScriptLocked !NotScriptLockedTxInsError
+  | ShelleyTxCmdQueryNotScriptLocked !ScriptLockedTxInsError
 
 renderShelleyTxCmdError :: ShelleyTxCmdError -> Text
 renderShelleyTxCmdError err =
@@ -495,33 +495,53 @@ runTxBuild (AnyCardanoEra era) (AnyConsensusModeParams cModeParams) networkId mS
                             validatedTxUpProp
                             validatedMintValue
                             validatedTxScriptValidity
+
       eInMode <- case toEraInMode era CardanoMode of
                    Just result -> return result
                    Nothing ->
                      left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outputOptions
                             (AnyConsensusMode CardanoMode) (AnyCardanoEra era))
 
-      let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc
+      SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError
+                             $ newExceptT readEnvSocketPath
 
-      (utxo, pparams, eraHistory, systemStart, stakePools) <-
+      let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc
+          localNodeConnInfo = LocalNodeConnectInfo
+                                     { localConsensusModeParams = CardanoModeParams $ EpochSlots 21600
+                                     , localNodeNetworkId = networkId
+                                     , localNodeSocketPath = sockPath
+                                     }
+      AnyCardanoEra nodeEra
+        <- firstExceptT (ShelleyTxCmdQueryConvenienceError . AcqFailure)
+             . newExceptT $ determineEra cModeParams localNodeConnInfo
+
+      (nodeEraUTxO, pparams, eraHistory, systemStart, stakePools) <-
         firstExceptT ShelleyTxCmdQueryConvenienceError . newExceptT
-          $ queryStateForBalancedTx era networkId allTxInputs
+          $ queryStateForBalancedTx nodeEra networkId allTxInputs
 
       firstExceptT ShelleyTxCmdTxInsDoNotExist
-        . hoistEither $ txInsExistInUTxO allTxInputs utxo
+        . hoistEither $ txInsExistInUTxO allTxInputs nodeEraUTxO
       firstExceptT ShelleyTxCmdQueryNotScriptLocked
-        . hoistEither $ notScriptLockedTxIns txinsc utxo
+        . hoistEither $ notScriptLockedTxIns txinsc nodeEraUTxO
 
       let cAddr = case anyAddressInEra era changeAddr of
                     Just addr -> addr
                     Nothing -> error $ "runTxBuild: Byron address used: " <> show changeAddr
 
+      -- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
+      -- We cannot use the user specified era to construct a query against a node because it may differ
+      -- from the node's era and this will result in the 'QueryEraMismatch' failure.
+      txEraUtxo <- case first ShelleyTxCmdTxEraCastErr (eraCast era nodeEraUTxO) of
+                     Right txEraUtxo -> return txEraUtxo
+                     Left e -> left e
+
       (BalancedTxBody balancedTxBody _ fee) <-
         firstExceptT ShelleyTxCmdBalanceTxBody
           . hoistEither
           $ makeTransactionBodyAutoBalance eInMode systemStart eraHistory
-                                           pparams stakePools utxo txBodyContent
+                                           pparams stakePools txEraUtxo txBodyContent
                                            cAddr mOverrideWits
+
       putStrLn $ "Estimated transaction fee: " <> (show fee :: String)
 
       case outputOptions of
@@ -531,10 +551,10 @@ runTxBuild (AnyCardanoEra era) (AnyConsensusModeParams cModeParams) networkId mS
               scriptExecUnitsMap <- firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither
                                       $ evaluateTransactionExecutionUnits
                                           eInMode systemStart eraHistory
-                                          pparams utxo balancedTxBody
+                                          pparams txEraUtxo balancedTxBody
               scriptCostOutput <- firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither
                                     $ renderScriptCosts
-                                        utxo
+                                        txEraUtxo
                                         executionUnitPrices
                                         (collectTxBodyScriptWitnesses txBodyContent)
                                         scriptExecUnitsMap