diff --git a/cabal.project b/cabal.project index 5e43d35da0..b04c1f8ade 100644 --- a/cabal.project +++ b/cabal.project @@ -19,8 +19,8 @@ index-state: packages: cardano-cli -program-options - ghc-options: -Werror +-- program-options +-- ghc-options: -Werror package cryptonite -- Using RDRAND instead of /dev/urandom as an entropy source for key diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 731c7cc6d9..4e5bba69d0 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -68,6 +68,7 @@ library Cardano.CLI.Commands.Node Cardano.CLI.Commands.Ping Cardano.CLI.Compatible.Commands + Cardano.CLI.Compatible.Exception Cardano.CLI.Compatible.Governance Cardano.CLI.Compatible.Run Cardano.CLI.Compatible.Transaction @@ -251,6 +252,7 @@ library prettyprinter, prettyprinter-ansi-terminal, random, + rio, split, strict-stm, text <2.1.2, diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Exception.hs b/cardano-cli/src/Cardano/CLI/Compatible/Exception.hs new file mode 100644 index 0000000000..845f53f7ec --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/Compatible/Exception.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.CLI.Compatible.Exception + ( CustomCliException (..) + , throwCliError + , fromEitherCli + , fromEitherIOCli + ) +where + +import Cardano.Api + +import GHC.Stack + +import RIO + +data CustomCliException where + CustomCliException + :: (Show error, Typeable error, Error error) + => error -> CallStack -> CustomCliException + +deriving instance Show CustomCliException + +instance Exception CustomCliException where + displayException (CustomCliException e cStack) = + unlines + [ show (prettyError e) + , prettyCallStack cStack + ] + +throwCliError :: MonadIO m => CustomCliException -> m a +throwCliError = throwIO + +fromEitherCli :: (HasCallStack, MonadIO m, Show e, Typeable e, Error e) => Either e a -> m a +fromEitherCli = \case + Left e -> throwCliError $ CustomCliException e callStack + Right a -> return a + +fromEitherIOCli :: (HasCallStack, MonadIO m, Show e, Typeable e, Error e) => IO (Either e a) -> m a +fromEitherIOCli action = do + result <- liftIO action + case result of + Left e -> throwCliError $ CustomCliException e callStack + Right a -> return a diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Run.hs b/cardano-cli/src/Cardano/CLI/Compatible/Run.hs index ae30b50b10..99df936a14 100644 --- a/cardano-cli/src/Cardano/CLI/Compatible/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Compatible/Run.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Compatible.Run ( CompatibleCmdError @@ -16,7 +17,7 @@ import Cardano.CLI.Compatible.Transaction import Cardano.CLI.Render import Cardano.CLI.Types.Errors.CmdError -import Data.Text (Text) +import RIO data CompatibleCmdError = CompatibleTransactionError CompatibleTransactionError @@ -32,6 +33,15 @@ runAnyCompatibleCommand (AnyCompatibleCommand cmd) = runCompatibleCommand cmd runCompatibleCommand :: CompatibleCommand era -> ExceptT CompatibleCmdError IO () runCompatibleCommand (CompatibleTransactionCmd txCmd) = - firstExceptT CompatibleTransactionError $ runCompatibleTransactionCmd txCmd + liftIO $ + executeRio + (runCompatibleTransactionCmd txCmd) runCompatibleCommand (CompatibleGovernanceCmds govCmd) = firstExceptT CompatibleGovernanceError $ runCompatibleGovernanceCmds govCmd + +-- | This is a temporary function until all commands are migrated to RIO +-- Once this happens we can remove this function and rely on `toplevelExceptionHandler` +executeRio :: RIO () () -> IO () +executeRio r = do + runRIO () r + `catch` (\(e :: SomeException) -> putStrLn $ displayException e) diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs index c083dda7bb..d0e0ff5e59 100644 --- a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs @@ -19,32 +19,32 @@ import Cardano.Api.Compatible import Cardano.Api.Ledger hiding (TxIn, VotingProcedures) import Cardano.Api.Shelley hiding (VotingProcedures) +import Cardano.CLI.Compatible.Exception import Cardano.CLI.Environment import Cardano.CLI.EraBased.Options.Common hiding (pRefScriptFp, pTxOutDatum) import Cardano.CLI.EraBased.Run.Transaction import Cardano.CLI.EraBased.Script.Certificate.Read import Cardano.CLI.EraBased.Script.Certificate.Types import Cardano.CLI.EraBased.Script.Proposal.Types -import Cardano.CLI.EraBased.Script.Types import Cardano.CLI.EraBased.Script.Vote.Types (CliVoteScriptRequirements, VoteScriptWitness (..)) +import Cardano.CLI.Orphans () import Cardano.CLI.Parser import Cardano.CLI.Read import Cardano.CLI.Types.Common -import Cardano.CLI.Types.Errors.BootstrapWitnessError import Cardano.CLI.Types.Errors.TxCmdError import Cardano.CLI.Types.Governance import Cardano.CLI.Types.TxFeature -import Data.Bifunctor (first) import Data.Foldable import Data.Function import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Text (Text) import Options.Applicative import qualified Options.Applicative as Opt +import RIO + pAllCompatibleTransactionCommands :: EnvCli -> ShelleyBasedEra era -> Parser (CompatibleTransactionCmds era) pAllCompatibleTransactionCommands envCli sbe = @@ -199,35 +199,23 @@ renderCompatibleTransactionCmd _ = "" data CompatibleTransactionError = CompatibleTxCmdError !TxCmdError - | CompatibleWitnessError !ReadWitnessSigningDataError - | CompatiblePParamsConversionError !ProtocolParametersConversionError - | CompatibleBootstrapWitnessError !BootstrapWitnessError | forall err. Error err => CompatibleFileError (FileError err) - | CompatibleTxBodyError !TxBodyError | CompatibleProposalError !ProposalError - | CompatibleVoteError !VoteError - | forall era. CompatibleVoteMergeError !(VotesMergingConflict era) - | CompatibleScriptWitnessError !ScriptWitnessError - | CompatibleScriptWitnessReadError !(FileError CliScriptWitnessError) + +instance Show CompatibleTransactionError where + show = show . prettyError instance Error CompatibleTransactionError where prettyError = \case CompatibleTxCmdError e -> renderTxCmdError e - CompatibleWitnessError e -> renderReadWitnessSigningDataError e - CompatiblePParamsConversionError e -> prettyError e - CompatibleBootstrapWitnessError e -> renderBootstrapWitnessError e CompatibleFileError e -> prettyError e - CompatibleTxBodyError e -> prettyError e CompatibleProposalError e -> pshow e - CompatibleVoteError e -> pshow e - CompatibleVoteMergeError e -> pshow e - CompatibleScriptWitnessError e -> renderScriptWitnessError e - CompatibleScriptWitnessReadError e -> prettyError e runCompatibleTransactionCmd :: forall era - . CompatibleTransactionCmds era - -> ExceptT CompatibleTransactionError IO () + . HasCallStack + => CompatibleTransactionCmds era + -> RIO () () runCompatibleTransactionCmd ( CreateCompatibleSignedTransaction sbe @@ -241,73 +229,76 @@ runCompatibleTransactionCmd fee certificates outputFp - ) = do - sks <- firstExceptT CompatibleWitnessError $ mapM (newExceptT . readWitnessSigningData) witnesses - - allOuts <- firstExceptT CompatibleTxCmdError $ mapM (toTxOutInAnyEra sbe) outs - - certFilesAndMaybeScriptWits <- - firstExceptT CompatibleScriptWitnessReadError $ - readCertificateScriptWitnesses sbe certificates - - certsAndMaybeScriptWits :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] <- - shelleyBasedEraConstraints sbe $ - sequence - [ fmap - (,cswScriptWitness <$> mSwit) - ( firstExceptT CompatibleFileError . newExceptT $ - readFileTextEnvelope AsCertificate (File certFile) - ) - | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits - ] - - (protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <- - caseShelleyToBabbageOrConwayEraOnwards - ( const $ do - prop <- maybe (pure $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal - return (prop, NoVotes) - ) - ( \w -> do - prop <- maybe (pure $ NoPParamsUpdate sbe) readProposalProcedureFile mProposalProcedure - votesAndWits <- - firstExceptT CompatibleVoteError . newExceptT $ - readVotingProceduresFiles w mVotes - votingProcedures <- - firstExceptT CompatibleVoteMergeError . hoistEither $ - mkTxVotingProcedures [(v, vswScriptWitness <$> mSwit) | (v, mSwit) <- votesAndWits] - return (prop, VotingProcedures w votingProcedures) - ) - sbe - - let certsRefInputs = - [ refInput - | (_, Just sWit) <- certsAndMaybeScriptWits - , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit - ] - - votesRefInputs = - [ refInput - | VotingProcedures _ (TxVotingProcedures _ (BuildTxWith voteMap)) <- [votes] - , sWit <- Map.elems voteMap - , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit - ] - - proposalsRefInputs = - [ refInput - | ProposalProcedures _ (TxProposalProcedures _ (BuildTxWith proposalMap)) <- [protocolUpdates] - , sWit <- Map.elems proposalMap - , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit - ] - - validatedRefInputs <- - liftEither . first CompatibleTxCmdError . validateTxInsReference $ - certsRefInputs <> votesRefInputs <> proposalsRefInputs - let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits - - -- this body is only for witnesses - apiTxBody <- - firstExceptT CompatibleTxBodyError $ - hoistEither $ + ) = + shelleyBasedEraConstraints sbe $ do + sks <- mapM (fromEitherIOCli . readWitnessSigningData) witnesses + + allOuts <- fromEitherIOCli . runExceptT $ mapM (toTxOutInAnyEra sbe) outs + + certFilesAndMaybeScriptWits <- + fromEitherIOCli $ + runExceptT $ + readCertificateScriptWitnesses sbe certificates + + certsAndMaybeScriptWits <- + liftIO $ + sequenceA + [ fmap (,cswScriptWitness <$> mSwit) $ + fromEitherIOCli $ + readFileTextEnvelope AsCertificate $ + File certFile + | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits + ] + + (protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <- + caseShelleyToBabbageOrConwayEraOnwards + ( const $ do + case mUpdateProposal of + Nothing -> return (NoPParamsUpdate sbe, NoVotes) + Just p -> do + pparamUpdate <- fromEitherIOCli $ runExceptT $ readUpdateProposalFile p + return (pparamUpdate, NoVotes) + ) + ( \w -> + case mProposalProcedure of + Nothing -> return (NoPParamsUpdate sbe, NoVotes) + Just prop -> do + pparamUpdate <- fromEitherIOCli $ runExceptT $ readProposalProcedureFile prop + votesAndWits <- fromEitherIOCli (readVotingProceduresFiles w mVotes) + votingProcedures <- + fromEitherCli $ mkTxVotingProcedures [(v, vswScriptWitness <$> mSwit) | (v, mSwit) <- votesAndWits] + return (pparamUpdate, VotingProcedures w votingProcedures) + ) + sbe + + let certsRefInputs = + [ refInput + | (_, Just sWit) <- certsAndMaybeScriptWits + , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + + votesRefInputs = + [ refInput + | VotingProcedures _ (TxVotingProcedures _ (BuildTxWith voteMap)) <- [votes] + , sWit <- Map.elems voteMap + , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + + proposalsRefInputs = + [ refInput + | ProposalProcedures _ (TxProposalProcedures _ (BuildTxWith proposalMap)) <- [protocolUpdates] + , sWit <- Map.elems proposalMap + , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + + validatedRefInputs <- + fromEitherCli . first CompatibleTxCmdError . validateTxInsReference $ + certsRefInputs <> votesRefInputs <> proposalsRefInputs + let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits + + -- this body is only for witnesses + apiTxBody <- + fromEitherCli $ createTransactionBody sbe $ defaultTxBodyContent sbe & setTxIns (map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) ins) @@ -316,21 +307,20 @@ runCompatibleTransactionCmd & setTxCertificates txCerts & setTxInsReference validatedRefInputs - let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks + let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks - byronWitnesses <- - firstExceptT CompatibleBootstrapWitnessError . hoistEither $ - mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron + byronWitnesses <- + fromEitherCli $ + mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron - let newShelleyKeyWits = map (makeShelleyKeyWitness sbe apiTxBody) sksShelley - allKeyWits = newShelleyKeyWits ++ byronWitnesses + let newShelleyKeyWits = map (makeShelleyKeyWitness sbe apiTxBody) sksShelley + allKeyWits = newShelleyKeyWits ++ byronWitnesses - signedTx <- - firstExceptT CompatiblePParamsConversionError . hoistEither $ - createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts + signedTx <- + fromEitherCli $ + createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts - firstExceptT CompatibleFileError $ - newExceptT $ + fromEitherIOCli $ writeTxFileTextEnvelopeCddl sbe outputFp signedTx where validateTxInsReference diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Script/Types.hs b/cardano-cli/src/Cardano/CLI/EraBased/Script/Types.hs index 979dd9381a..c9365e45db 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Script/Types.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Script/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} diff --git a/cardano-cli/src/Cardano/CLI/Orphans.hs b/cardano-cli/src/Cardano/CLI/Orphans.hs index 96037ba6e5..3e0c3c4306 100644 --- a/cardano-cli/src/Cardano/CLI/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Orphans.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} @@ -10,10 +11,13 @@ where import Cardano.Api import qualified Cardano.Api.Ledger as L -import Cardano.Api.Shelley (scriptDataToJsonDetailedSchema) +import Cardano.Api.Shelley (VotesMergingConflict, scriptDataToJsonDetailedSchema) import Data.Aeson +instance Error (VotesMergingConflict era) where + prettyError = pretty . show + -- TODO upstream this orphaned instance to the ledger instance (L.EraTxOut ledgerera, L.EraGov ledgerera) => ToJSON (L.NewEpochState ledgerera) where toJSON (L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu nesPd _stashedAvvm) = diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index ecaad26b35..743bc58056 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -124,6 +124,7 @@ import Prelude import Control.Exception (bracket) import Control.Monad (forM, unless, when) +import Control.Monad.Catch (Exception) import qualified Data.Aeson as Aeson import Data.Bifunctor import Data.ByteString (ByteString) @@ -717,6 +718,15 @@ data ReadWitnessSigningDataError ReadWitnessSigningDataSigningKeyAndAddressMismatch deriving Show +instance Error ReadWitnessSigningDataError where + prettyError = \case + ReadWitnessSigningDataSigningKeyDecodeError fileErr -> + prettyError fileErr + ReadWitnessSigningDataScriptError fileErr -> + prettyError fileErr + ReadWitnessSigningDataSigningKeyAndAddressMismatch -> + "Only a Byron signing key may be accompanied by a Byron address." + -- | Render an error message for a 'ReadWitnessSigningDataError'. renderReadWitnessSigningDataError :: ReadWitnessSigningDataError -> Doc ann renderReadWitnessSigningDataError = \case diff --git a/cardano-cli/src/Cardano/CLI/Run.hs b/cardano-cli/src/Cardano/CLI/Run.hs index 027db218c1..51267ab609 100644 --- a/cardano-cli/src/Cardano/CLI/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Run.hs @@ -39,10 +39,8 @@ import Cardano.CLI.Types.Errors.NodeCmdError import Cardano.CLI.Types.Errors.QueryCmdError import Cardano.Git.Rev (gitRev) -import Control.Monad (forM_) import Data.Function import qualified Data.List as L -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Version (showVersion) @@ -53,6 +51,7 @@ import System.Info (arch, compilerName, compilerVersion, os) import qualified System.IO as IO import Paths_cardano_cli (version) +import RIO data ClientCommandErrors = ByronClientError ByronClientCmdError diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs index 6428a3a266..9ef255d369 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs @@ -4,7 +4,7 @@ module Cardano.CLI.Types.Errors.BootstrapWitnessError ) where -import Prettyprinter +import Cardano.Api -- | Error constructing a Shelley bootstrap witness (i.e. a Byron key witness -- in the Shelley era). @@ -14,6 +14,9 @@ data BootstrapWitnessError MissingNetworkIdOrByronAddressError deriving Show +instance Error BootstrapWitnessError where + prettyError = renderBootstrapWitnessError + -- | Render an error message for a 'BootstrapWitnessError'. renderBootstrapWitnessError :: BootstrapWitnessError -> Doc ann renderBootstrapWitnessError MissingNetworkIdOrByronAddressError = diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index 47f77f0c16..e590ca44ad 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -95,6 +95,12 @@ data TxCmdError | TxCmdHashCheckError L.Url HashCheckError | TxCmdUnregisteredStakeAddress !(Set StakeCredential) +instance Show TxCmdError where + show = show . renderTxCmdError + +instance Error TxCmdError where + prettyError = renderTxCmdError + renderTxCmdError :: TxCmdError -> Doc ann renderTxCmdError = \case TxCmdProtocolParamsConverstionError err' ->