#299 Fix 'MissingRedeemers' error when deregistering Plutus stake add…

…ress
IntersectMBO · Sep 29, 2023 · 945cb67 · 945cb67
1 parent b8f820b
commit 945cb67
Show file tree

Hide file tree

Showing 4 changed files with 62 additions and 42 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -71,6 +71,7 @@ import           Data.Type.Equality (TestEquality (..))
 import           Lens.Micro ((^.))
 import qualified System.IO as IO
 
+
 runTransactionCmds :: TransactionCmds era -> ExceptT TxCmdError IO ()
 runTransactionCmds cmd =
   case cmd of
@@ -173,13 +174,13 @@ runTxBuildCmd
               readFileTextEnvelope AsCertificate (File certFile))
           | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
           ]
-  withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError
-                                     $ readScriptWitnessFilesThruple era wdrls
-  txMetadata <- firstExceptT TxCmdMetadataError
-                  . newExceptT $ readTxMetadata era metadataSchema metadataFiles
+  withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $
+    readScriptWitnessFilesThruple era wdrls
+  txMetadata <- firstExceptT TxCmdMetadataError . newExceptT $
+    readTxMetadata era metadataSchema metadataFiles
   valuesWithScriptWits <- readValueScriptWitnesses era $ fromMaybe mempty mValue
   scripts <- firstExceptT TxCmdScriptFileError $
-                     mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles
+    mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles
   txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts era scripts
 
   mProp <- forM mUpProp $ \(UpdateProposalFile upFp) ->
@@ -203,17 +204,15 @@ runTxBuildCmd
   let filteredTxinsc = Set.toList $ Set.fromList txinsc
 
   -- We need to construct the txBodycontent outside of runTxBuild
-  BalancedTxBody txBodycontent balancedTxBody _ _ <-
+  BalancedTxBody txBodyContent balancedTxBody _ _ <-
     runTxBuild
       era socketPath consensusModeParams nid mScriptValidity inputsAndMaybeScriptWits readOnlyRefIns filteredTxinsc
       mReturnCollateral mTotCollateral txOuts changeAddr valuesWithScriptWits mLowBound
       mUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits
       requiredSigners txAuxScripts txMetadata mProp mOverrideWits votes proposals outputOptions
 
-  mScriptWits <-
-    case cardanoEraStyle era of
-      LegacyByronEra -> return []
-      ShelleyBasedEra sbe -> return $ collectTxBodyScriptWitnesses sbe txBodycontent
+  let mScriptWits =
+        forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent
 
   let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
@@ -230,7 +229,7 @@ runTxBuildCmd
   -- the script cost vs having to build the tx body each time
   case outputOptions of
     OutputScriptCostOnly fp -> do
-      let BuildTxWith mTxProtocolParams = txProtocolParams txBodycontent
+      let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent
 
       pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody)
       executionUnitPrices <- pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable)
@@ -519,12 +518,12 @@ runTxBuild
       dummyFee = Just $ Lovelace 0
       inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits]
 
-  -- Pure
   let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
                              (snd valuesWithScriptWits)
                              certsAndMaybeScriptWits
-                             withdrawals readOnlyRefIns
+                             withdrawals
+                             readOnlyRefIns
 
   validatedCollateralTxIns <- hoistEither $ validateTxInsCollateral era txinsc
   validatedRefInputs <- hoistEither $ validateTxInsReference era allReferenceInputs

diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs
@@ -139,6 +139,7 @@ import           GHC.IO.Handle.FD (openFileBlocking)
 import qualified Options.Applicative as Opt
 import           System.IO (IOMode (ReadMode))
 
+
 -- Metadata
 
 data MetadataError
@@ -288,9 +289,9 @@ readScriptWitness era (PlutusScriptWitnessFiles
     case script' of
       PlutusScript version pscript -> do
         datum <- firstExceptT ScriptWitnessErrorScriptData
-                   $ readScriptDatumOrFile    datumOrFile
+                   $ readScriptDatumOrFile datumOrFile
         redeemer <- firstExceptT ScriptWitnessErrorScriptData
-                      $ readScriptRedeemerOrFile redeemerOrFile
+                   $ readScriptRedeemerOrFile redeemerOrFile
         return $ PlutusScriptWitness
                    langInEra version (PScript pscript)
                    datum
@@ -619,6 +620,7 @@ data SomeSigningWitness
   | AGenesisDelegateExtendedSigningWitness  (SigningKey GenesisDelegateExtendedKey)
   | AGenesisUTxOSigningWitness              (SigningKey GenesisUTxOKey)
   | ADRepSigningWitness                     (SigningKey DRepKey)
+  deriving Show
 
 
 -- | Data required for constructing a Shelley bootstrap witness.

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs
@@ -15,8 +15,8 @@ import           Cardano.Api.Shelley
 
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Common
-import           Cardano.CLI.Types.Errors.ProtocolParamsError
 import           Cardano.CLI.Types.Errors.BootstrapWitnessError
+import           Cardano.CLI.Types.Errors.ProtocolParamsError
 import           Cardano.CLI.Types.Errors.TxValidationError
 import           Cardano.CLI.Types.Output
 import           Cardano.CLI.Types.TxFeature

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
@@ -36,6 +34,7 @@ module Cardano.CLI.Types.Errors.TxValidationError
   ) where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley
 
 import           Prelude
@@ -270,30 +269,50 @@ validateTxCertificates era certsAndScriptWitnesses = cardanoEraConstraints era $
       reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses
   pure $ TxCertificates supported certs $ BuildTxWith reqWits
   where
-   -- We get the stake credential witness for a certificate that requires it.
-   -- NB: Only stake address deregistration and delegation requires
-   -- witnessing (witness can be script or key)
-   deriveStakeCredentialWitness
-     :: Certificate era
-     -> Maybe StakeCredential
-   deriveStakeCredentialWitness _cert = Nothing
-    --  case cert of
-    --    -- TODO: Conway era
-    --    -- StakeAddressDeregistrationCertificate sCred -> Just sCred
-    --    -- StakeAddressPoolDelegationCertificate sCred _ -> Just sCred
-    --    _ -> Nothing
-
-   convert
-     :: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
-     -> Maybe (StakeCredential, Witness WitCtxStake era)
-   convert (cert, mScriptWitnessFiles) = do
-     sCred <- deriveStakeCredentialWitness cert
-     case mScriptWitnessFiles of
-       Just sWit -> do
-         Just ( sCred
-              , ScriptWitness ScriptWitnessForStakeAddr sWit
-              )
-       Nothing -> Just (sCred, KeyWitness KeyWitnessForStakeAddr)
+    -- We get the stake credential witness for a certificate that requires it.
+    -- NB: Only stake address deregistration and delegation requires
+    -- witnessing (witness can be script or key)
+    deriveStakeCredentialWitness
+      :: Certificate era
+      -> Maybe StakeCredential
+    deriveStakeCredentialWitness = fmap fromShelleyStakeCredential . \case
+      ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $
+        case shelleyCert of
+          L.RegTxCert _sCred         -> Nothing -- not required
+          L.UnRegTxCert sCred        -> Just sCred
+          L.DelegStakeTxCert sCred _ -> Just sCred
+          L.RegPoolTxCert _          -> Nothing
+          L.RetirePoolTxCert _ _     -> Nothing
+          L.MirTxCert _              -> Nothing
+          L.GenesisDelegTxCert{}     -> Nothing
+
+      ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
+        case conwayCert of
+          L.RegPoolTxCert _                 -> Nothing
+          L.RetirePoolTxCert _ _            -> Nothing
+          L.RegTxCert _                     -> Nothing
+          L.UnRegTxCert sCred               -> Just sCred
+          L.RegDepositTxCert _ _            -> Nothing
+          L.UnRegDepositTxCert sCred _      -> Just sCred
+          L.DelegTxCert sCred _             -> Just sCred
+          L.RegDepositDelegTxCert sCred _ _ -> Just sCred
+          L.AuthCommitteeHotKeyTxCert{}     -> Nothing
+          L.ResignCommitteeColdTxCert _     -> Nothing
+          L.RegDRepTxCert{}                 -> Nothing
+          L.UnRegDRepTxCert{}               -> Nothing
+          L.UpdateDRepTxCert{}              -> Nothing
+
+    convert
+      :: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
+      -> Maybe (StakeCredential, Witness WitCtxStake era)
+    convert (cert, mScriptWitnessFiles) = do
+      sCred <- deriveStakeCredentialWitness cert
+      case mScriptWitnessFiles of
+        Just sWit -> do
+          Just ( sCred
+               , ScriptWitness ScriptWitnessForStakeAddr sWit
+               )
+        Nothing -> Just (sCred, KeyWitness KeyWitnessForStakeAddr)
 
 newtype TxProtocolParametersValidationError
   = ProtocolParametersNotSupported AnyCardanoEra