Convert runCompatibleTransactionCmd to use RIO monad

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/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,

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

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)

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

cardano-cli/src/Cardano/CLI/EraBased/Script/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 

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) =