diff --git a/cardano-cli/src/Cardano/CLI/Byron/Run.hs b/cardano-cli/src/Cardano/CLI/Byron/Run.hs index 634c54eb55..622dac14a6 100644 --- 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 index 84287b9aba..de2b9af47f 100644 --- 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 index a65d66ee2f..633e08abad 100644 --- 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 index 98af501e7e..29e610e7b3 100644 --- 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 index 97d125cb48..d24533fe9b 100644 --- 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