Example CustomCliException

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

cardano-cli/src/Cardano/CLI/Compatible/Exception.hs

@@ -4,6 +4,8 @@
 
 module Cardano.CLI.Compatible.Exception
   ( CustomCliException (..)
+  , throwCliError
+  , fromEitherIOCli
   )
 where
 
@@ -21,8 +23,18 @@ data CustomCliException where
 deriving instance Show CustomCliException
 
 instance Exception CustomCliException where
-  displayException (CustomCliException e cs) =
+  displayException (CustomCliException e cStack) =
     unlines
       [ show (prettyError e)
-      , prettyCallStack cs
+      , prettyCallStack cStack
       ]
+
+throwCliError :: MonadIO m => CustomCliException -> m a
+throwCliError = throwIO
+
+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

cardano-cli/src/Cardano/CLI/Compatible/Run.hs

@@ -12,7 +12,6 @@ where
 import           Cardano.Api
 
 import           Cardano.CLI.Compatible.Commands
-import           Cardano.CLI.Compatible.Exception
 import           Cardano.CLI.Compatible.Governance
 import           Cardano.CLI.Compatible.Transaction
 import           Cardano.CLI.Render
@@ -45,8 +44,4 @@ runCompatibleCommand (CompatibleGovernanceCmds govCmd) =
 executeRio :: RIO () () -> IO ()
 executeRio r = do
   runRIO () r
-    `catch` ( \e ->
-                case fromException e of
-                  Just custom@(CustomCliException{}) -> putStrLn $ displayException custom
-                  Nothing -> putStrLn $ displayException e
-            )
+    `catch` (\(e :: SomeException) -> putStrLn $ displayException e)

cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs

@@ -19,13 +19,13 @@ 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 ()
@@ -40,8 +40,6 @@ import           Data.Foldable
 import           Data.Function
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
-import           Data.Text (Text)
-import           GHC.Exts (IsList (..))
 import           Options.Applicative
 import qualified Options.Applicative as Opt
 
@@ -221,7 +219,8 @@ instance Error CompatibleTransactionError where
 -- constraint here and to all those functions.
 runCompatibleTransactionCmd
   :: forall era
-   . CompatibleTransactionCmds era
+   . HasCallStack
+  => CompatibleTransactionCmds era
   -> RIO () ()
 runCompatibleTransactionCmd
   ( CreateCompatibleSignedTransaction
@@ -238,12 +237,12 @@ runCompatibleTransactionCmd
       outputFp
     ) =
     shelleyBasedEraConstraints sbe $ do
-      sks <- mapM (fromEitherIO . readWitnessSigningData) witnesses
+      sks <- mapM (fromEitherIOCli . readWitnessSigningData) witnesses
 
-      allOuts <- fromEitherIO . runExceptT $ mapM (toTxOutInAnyEra sbe) outs
+      allOuts <- fromEitherIOCli . runExceptT $ mapM (toTxOutInAnyEra sbe) outs
 
       certFilesAndMaybeScriptWits <-
-        fromEitherIO $
+        fromEitherIOCli $
           runExceptT $
             readCertificateScriptWitnesses sbe certificates
 
@@ -263,16 +262,17 @@ runCompatibleTransactionCmd
               case mUpdateProposal of
                 Nothing -> return (NoPParamsUpdate sbe, NoVotes)
                 Just p -> do
-                  pparamUpdate <- fromEitherIO $ runExceptT $ readUpdateProposalFile p
+                  pparamUpdate <- fromEitherIOCli $ runExceptT $ readUpdateProposalFile p
                   return (pparamUpdate, NoVotes)
           )
           ( \w ->
               case mProposalProcedure of
                 Nothing -> return (NoPParamsUpdate sbe, NoVotes)
                 Just prop -> do
-                  pparamUpdate <- fromEitherIO $ runExceptT $ readProposalProcedureFile prop
-                  votesAndWits <- fromEitherIO (readVotingProceduresFiles w mVotes)
-                  votingProcedures <- fromEither $ mkTxVotingProcedures votesAndWits
+                  pparamUpdate <- fromEitherIOCli $ runExceptT $ readProposalProcedureFile prop
+                  votesAndWits <- fromEitherIOCli (readVotingProceduresFiles w mVotes)
+                  votingProcedures <-
+                    fromEither $ mkTxVotingProcedures [(v, vswScriptWitness <$> mSwit) | (v, mSwit) <- votesAndWits]
                   return (pparamUpdate, VotingProcedures w votingProcedures)
           )
           sbe
@@ -300,7 +300,7 @@ runCompatibleTransactionCmd
       validatedRefInputs <-
         fromEither . first CompatibleTxCmdError . validateTxInsReference $
           certsRefInputs <> votesRefInputs <> proposalsRefInputs
-      let txCerts = convertCertificates certsAndMaybeScriptWits
+      let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits
 
       -- this body is only for witnesses
       apiTxBody <-
@@ -326,7 +326,7 @@ runCompatibleTransactionCmd
         fromEither $
           createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts
 
-      fromEitherIO $
+      fromEitherIOCli $
         writeTxFileTextEnvelopeCddl sbe outputFp signedTx
    where
     validateTxInsReference

cardano-cli/src/Cardano/CLI/Read.hs

@@ -718,7 +718,14 @@ data ReadWitnessSigningDataError
     ReadWitnessSigningDataSigningKeyAndAddressMismatch
   deriving Show
 
-instance Exception ReadWitnessSigningDataError
+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

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

cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs

@@ -33,7 +33,6 @@ import           Cardano.CLI.Types.Output
 import           Cardano.CLI.Types.TxFeature
 import qualified Cardano.Prelude as List
 
-import           Control.Monad.Catch (Exception)
 import           Data.Set (Set)
 import           Data.Text (Text)
 
@@ -96,11 +95,12 @@ data TxCmdError
   | TxCmdHashCheckError L.Url HashCheckError
   | TxCmdUnregisteredStakeAddress !(Set StakeCredential)
 
-instance Exception TxCmdError
-
 instance Show TxCmdError where
   show = show . renderTxCmdError
 
+instance Error TxCmdError where
+  prettyError = renderTxCmdError
+
 renderTxCmdError :: TxCmdError -> Doc ann
 renderTxCmdError = \case
   TxCmdProtocolParamsConverstionError err' ->