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

…ress
IntersectMBO · Oct 3, 2023 · 99e3ae7 · 99e3ae7
1 parent b95fd9d
commit 99e3ae7
Show file tree

Hide file tree

Showing 4 changed files with 58 additions and 36 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) ->
@@ -517,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
@@ -620,6 +621,7 @@ data SomeSigningWitness
   | AGenesisUTxOSigningWitness              (SigningKey GenesisUTxOKey)
   | ADRepSigningWitness                     (SigningKey DRepKey)
   | ACommitteeSigningWitness                (SigningKey CommitteeColdKey)
+  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 #-}
@@ -37,6 +35,7 @@ module Cardano.CLI.Types.Errors.TxValidationError
   ) where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley
 
 import           Prelude
@@ -247,30 +246,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