#299 Fix 'MissingRedeemers'

IntersectMBO · Sep 26, 2023 · ba86faf · ba86faf
1 parent 5878fe3
commit ba86faf
Show file tree

Hide file tree

Showing 5 changed files with 58 additions and 40 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Byron/Run.hs b/cardano-cli/src/Cardano/CLI/Byron/Run.hs
@@ -32,11 +32,12 @@ import           Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, le
 import           Data.Bifunctor (Bifunctor (..))
 import qualified Data.ByteString.Char8 as BS
 import           Data.Text (Text)
-import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
+import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.Builder as Builder
 import qualified Data.Text.Lazy.IO as TL
 import qualified Formatting as F
+import           Text.Pretty.Simple (pShow)
 
 -- | Data type that encompasses all the possible errors of the
 -- Byron client.
@@ -60,7 +61,7 @@ renderByronClientCmdError err =
     ByronCmdKeyFailure e -> renderByronKeyFailure e
     ByronCmdTxError e -> renderByronTxError e
     ByronCmdTxSubmitError e ->
-      "Error while submitting Byron tx: " <> Text.pack (show e)
+      "Error while submitting Byron tx: " <> show e -- TODO FIXME pattern match on a constructor
     ByronCmdUpdateProposalError e -> renderByronUpdateProposalError e
     ByronCmdVoteError e -> renderByronVoteError e
 

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -65,12 +65,12 @@ import           Data.Maybe (catMaybes, fromMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
-import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 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 +173,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) ->
@@ -210,10 +210,13 @@ runTxBuildCmd
       mUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits
       requiredSigners txAuxScripts txMetadata mProp mOverrideWits votes proposals outputOptions
 
+
   mScriptWits <-
     case cardanoEraStyle era of
       LegacyByronEra -> return []
-      ShelleyBasedEra sbe -> return $ collectTxBodyScriptWitnesses sbe txBodycontent
+      ShelleyBasedEra sbe -> do
+        return $ collectTxBodyScriptWitnesses sbe txBodycontent
+
 
   let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
@@ -519,12 +522,13 @@ 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
@@ -980,7 +984,7 @@ runTxSubmitCmd socketPath (AnyConsensusModeParams cModeParams) network txFilePat
       Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted."
       Net.Tx.SubmitFail reason ->
         case reason of
-          TxValidationErrorInMode err _eraInMode -> left . TxCmdTxSubmitError . Text.pack $ show err
+          TxValidationErrorInMode err _eraInMode -> left . TxCmdTxSubmitError . Text.toStrict $ pShow err
           TxValidationEraMismatch mismatchErr -> left $ TxCmdTxSubmitErrorEraMismatch mismatchErr
 
 -- ----------------------------------------------------------------------------

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
@@ -295,9 +296,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
@@ -4,7 +4,8 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns-off #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Cardano.CLI.Types.Errors.TxValidationError
   ( TxAuxScriptsValidationError(..)
@@ -35,6 +36,7 @@ module Cardano.CLI.Types.Errors.TxValidationError
   ) where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley
 
 import           Prelude
@@ -274,30 +276,39 @@ validateTxCertificates era certsAndScriptWitnesses =
           reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses
       return $ 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
+          _                          -> Nothing
+
+      ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
+        case conwayCert of
+          L.RegDepositTxCert _sCred _       -> Nothing -- not required
+          L.UnRegDepositTxCert sCred _      -> Just sCred
+          L.DelegTxCert sCred _             -> Just sCred
+          L.RegDepositDelegTxCert 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)
 
 newtype TxProtocolParametersValidationError
   = ProtocolParametersNotSupported AnyCardanoEra