Merge pull request #840 from IntersectMBO/smelc/add-transaction-view-…

…under-debug Add era-independent "debug transaction view" command
IntersectMBO · Jul 18, 2024 · 4d3dbdb · 4d3dbdb
2 parents d4c08cf + e80203b
commit 4d3dbdb
Show file tree

Hide file tree

Showing 22 changed files with 211 additions and 157 deletions.
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -60,6 +60,7 @@ library
     Cardano.CLI.Commands
     Cardano.CLI.Commands.Debug
     Cardano.CLI.Commands.Debug.LogEpochState
+    Cardano.CLI.Commands.Debug.TransactionView
     Cardano.CLI.Commands.Hash
     Cardano.CLI.Commands.Ping
     Cardano.CLI.Environment
@@ -155,6 +156,7 @@ library
     Cardano.CLI.Run
     Cardano.CLI.Run.Debug
     Cardano.CLI.Run.Debug.LogEpochState
+    Cardano.CLI.Run.Debug.TransactionView
     Cardano.CLI.Run.Hash
     Cardano.CLI.Run.Ping
     Cardano.CLI.TopHandler
@@ -164,6 +166,7 @@ library
     Cardano.CLI.Types.Errors.BootstrapWitnessError
     Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError
     Cardano.CLI.Types.Errors.CmdError
+    Cardano.CLI.Types.Errors.DebugCmdError
     Cardano.CLI.Types.Errors.DelegationError
     Cardano.CLI.Types.Errors.GenesisCmdError
     Cardano.CLI.Types.Errors.GovernanceActionsError

diff --git a/cardano-cli/src/Cardano/CLI/Commands/Debug.hs b/cardano-cli/src/Cardano/CLI/Commands/Debug.hs
@@ -4,6 +4,8 @@ module Cardano.CLI.Commands.Debug
 where
 
 import           Cardano.CLI.Commands.Debug.LogEpochState
+import           Cardano.CLI.Commands.Debug.TransactionView
 
-newtype DebugCmds
+data DebugCmds
   = DebugLogEpochStateCmd LogEpochStateCmdArgs
+  | DebugTransactionViewCmd TransactionViewCmdArgs
diff --git a/cardano-cli/src/Cardano/CLI/Commands/Debug/TransactionView.hs b/cardano-cli/src/Cardano/CLI/Commands/Debug/TransactionView.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+
+module Cardano.CLI.Commands.Debug.TransactionView where
+
+import           Cardano.CLI.Types.Common
+
+data TransactionViewCmdArgs = TransactionViewCmdArgs
+  { outputFormat :: !ViewOutputFormat
+  , mOutFile :: !(Maybe (File () Out))
+  , inputTxBodyOrTxFile :: !InputTxBodyOrTxFile
+  }
+  deriving Show
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -44,7 +44,8 @@ import qualified Cardano.Chain.Common as Byron
 import qualified Cardano.CLI.EraBased.Commands.Transaction as Cmd
 import           Cardano.CLI.EraBased.Run.Genesis
 import           Cardano.CLI.EraBased.Run.Query
-import           Cardano.CLI.Json.Friendly (FriendlyFormat (..), friendlyTx, friendlyTxBody)
+import           Cardano.CLI.Json.Friendly (friendlyTx, friendlyTxBody,
+                   viewOutputFormatToFriendlyFormat)
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.BootstrapWitnessError
@@ -1715,16 +1716,12 @@ runTransactionViewCmd
         -- this would mean that we'd have an empty list of witnesses mentioned in the output, which
         -- is arguably not part of the transaction body.
         firstExceptT TxCmdWriteFileError . newExceptT $
-          case outputFormat of
-            ViewOutputFormatYaml -> friendlyTxBody FriendlyYaml mOutFile (toCardanoEra era) txbody
-            ViewOutputFormatJson -> friendlyTxBody FriendlyJson mOutFile (toCardanoEra era) txbody
+          friendlyTxBody (viewOutputFormatToFriendlyFormat outputFormat) mOutFile (toCardanoEra era) txbody
       InputTxFile (File txFilePath) -> do
         txFile <- liftIO $ fileOrPipe txFilePath
         InAnyShelleyBasedEra era tx <- lift (readFileTx txFile) & onLeft (left . TxCmdTextEnvCddlError)
         firstExceptT TxCmdWriteFileError . newExceptT $
-          case outputFormat of
-            ViewOutputFormatYaml -> friendlyTx FriendlyYaml mOutFile (toCardanoEra era) tx
-            ViewOutputFormatJson -> friendlyTx FriendlyJson mOutFile (toCardanoEra era) tx
+          friendlyTx (viewOutputFormatToFriendlyFormat outputFormat) mOutFile (toCardanoEra era) tx
 
 -- ----------------------------------------------------------------------------
 -- Witness commands

diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs
@@ -30,6 +30,7 @@ module Cardano.CLI.Json.Friendly
 
     -- * Ubiquitous types
   , FriendlyFormat (..)
+  , viewOutputFormatToFriendlyFormat
   )
 where
 
@@ -41,6 +42,7 @@ import           Cardano.Api.Shelley (Address (ShelleyAddress), Hash (..),
                    ShelleyLedgerEra, StakeAddress (..), fromShelleyPaymentCredential,
                    fromShelleyStakeReference, toShelleyStakeCredential)
 
+import           Cardano.CLI.Types.Common (ViewOutputFormat (..))
 import           Cardano.CLI.Types.MonadWarning (MonadWarning, eitherToWarning, runWarningIO)
 import           Cardano.Prelude (Foldable (..), first)
 
@@ -74,6 +76,11 @@ import           GHC.Unicode (isAlphaNum)
 
 data FriendlyFormat = FriendlyJson | FriendlyYaml
 
+viewOutputFormatToFriendlyFormat :: ViewOutputFormat -> FriendlyFormat
+viewOutputFormatToFriendlyFormat = \case
+  ViewOutputFormatJson -> FriendlyJson
+  ViewOutputFormatYaml -> FriendlyYaml
+
 friendly
   :: (MonadIO m, Aeson.ToJSON a)
   => FriendlyFormat
@@ -234,39 +241,46 @@ friendlyTxBodyImpl
                  , "update proposal" .= friendlyUpdateProposal txUpdateProposal
                  , "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound)
                  , "withdrawals" .= friendlyWithdrawals txWithdrawals
-                 , "governance actions"
-                    .= ( inEonForEra
-                          Null
-                          ( \(cOnwards :: ConwayEraOnwards era) ->
-                              case txProposalProcedures of
-                                Nothing -> Null
-                                Just (Featured _ TxProposalProceduresNone) -> Null
-                                Just (Featured _ (TxProposalProcedures lProposals _witnesses)) ->
-                                  friendlyLedgerProposals cOnwards $ toList lProposals
-                          )
-                          era
-                       )
-                 , "voters"
-                    .= ( inEonForEra
-                          Null
-                          ( \cOnwards ->
-                              case txVotingProcedures of
-                                Nothing -> Null
-                                Just (Featured _ TxVotingProceduresNone) -> Null
-                                Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
-                                  friendlyVotingProcedures cOnwards votes
-                          )
-                          era
-                       )
-                 , "currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)
-                 , "treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)
                  ]
+              ++ ( caseByronToBabbageOrConwaysEraOnwards
+                    ( \cOnwards ->
+                        case txProposalProcedures of
+                          Nothing -> []
+                          Just (Featured _ TxProposalProceduresNone) -> []
+                          Just (Featured _ (TxProposalProcedures lProposals _witnesses)) ->
+                            ["governance actions" .= (friendlyLedgerProposals cOnwards $ toList lProposals)]
+                    )
+                    era
+                 )
+              ++ ( caseByronToBabbageOrConwaysEraOnwards
+                    ( \cOnwards ->
+                        case txVotingProcedures of
+                          Nothing -> []
+                          Just (Featured _ TxVotingProceduresNone) -> []
+                          Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
+                            ["voters" .= friendlyVotingProcedures cOnwards votes]
+                    )
+                    era
+                 )
+              ++ ( caseByronToBabbageOrConwaysEraOnwards
+                    (const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
+                    era
+                 )
+              ++ ( caseByronToBabbageOrConwaysEraOnwards
+                    (const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
+                    era
+                 )
           )
    where
     friendlyLedgerProposals
       :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value
     friendlyLedgerProposals cOnwards proposalProcedures =
       Array $ Vector.fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures
+    caseByronToBabbageOrConwaysEraOnwards :: (ConwayEraOnwards era -> [a]) -> CardanoEra era -> [a]
+    caseByronToBabbageOrConwaysEraOnwards f =
+      caseByronOrShelleyBasedEra
+        []
+        (caseShelleyToBabbageOrConwayEraOnwards (const []) f)
 
 friendlyLedgerProposal
   :: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value
@@ -631,7 +645,9 @@ renderCertificate sbe = \case
 
   delegateeJson
     :: L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
-    => ShelleyBasedEra era -> L.Delegatee (L.EraCrypto (ShelleyLedgerEra era)) -> Aeson.Value
+    => ShelleyBasedEra era
+    -> L.Delegatee (L.EraCrypto (ShelleyLedgerEra era))
+    -> Aeson.Value
   delegateeJson _ =
     object . \case
       L.DelegStake hk@L.KeyHash{} ->

diff --git a/cardano-cli/src/Cardano/CLI/Options/Debug.hs b/cardano-cli/src/Cardano/CLI/Options/Debug.hs
@@ -15,6 +15,7 @@ import           Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..))
 
 import           Cardano.CLI.Commands.Debug
 import           Cardano.CLI.Commands.Debug.LogEpochState
+import           Cardano.CLI.Commands.Debug.TransactionView
 import           Cardano.CLI.Environment
 import           Cardano.CLI.EraBased.Options.Common
 
@@ -45,6 +46,13 @@ pDebugCmds envCli =
               , " The log file format is line delimited JSON."
               , " The command will not terminate."
               ]
+    , subParser "transaction" $
+        Opt.info
+          ( asum
+              [ subParser "view" (Opt.info pTransactionView $ Opt.progDesc "Print a transaction.")
+              ]
+          )
+          (Opt.progDesc "Transaction commands")
     ]
  where
   pLogEpochStateCmdArgs :: Parser DebugCmds
@@ -56,6 +64,13 @@ pDebugCmds envCli =
         <*> pFileOutDirection
           "out-file"
           "Output filepath of the log file.  The log file format is line delimited JSON."
+  pTransactionView :: Parser DebugCmds
+  pTransactionView =
+    fmap DebugTransactionViewCmd $
+      TransactionViewCmdArgs
+        <$> pTxViewOutputFormat
+        <*> pMaybeOutputFile
+        <*> pInputTxOrTxBodyFile
 
 pNodeConfigurationFileIn :: Parser (NodeConfigFile In)
 pNodeConfigurationFileIn =

diff --git a/cardano-cli/src/Cardano/CLI/Run.hs b/cardano-cli/src/Cardano/CLI/Run.hs
@@ -80,7 +80,7 @@ renderClientCommandError = \case
   PingClientError err ->
     renderPingClientCmdError err
   DebugCmdError err ->
-    renderDebugCmdError err
+    prettyError err
 
 runDisplayVersion :: ExceptT ClientCommandErrors IO ()
 runDisplayVersion = do

diff --git a/cardano-cli/src/Cardano/CLI/Run/Debug.hs b/cardano-cli/src/Cardano/CLI/Run/Debug.hs
@@ -4,22 +4,17 @@ module Cardano.CLI.Run.Debug
   ( DebugCmdError (..)
   , runLogEpochStateCmd
   , runDebugCmds
-  , renderDebugCmdError
   )
 where
 
+import           Cardano.Api
+
 import           Cardano.CLI.Commands.Debug
 import           Cardano.CLI.Run.Debug.LogEpochState
-
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Except
-import           Prettyprinter
-
-data DebugCmdError = DebugCmdFailed
+import           Cardano.CLI.Run.Debug.TransactionView (runTransactionViewCmd)
+import           Cardano.CLI.Types.Errors.DebugCmdError
 
 runDebugCmds :: DebugCmds -> ExceptT DebugCmdError IO ()
 runDebugCmds = \case
   DebugLogEpochStateCmd cmd -> liftIO $ runLogEpochStateCmd cmd
-
-renderDebugCmdError :: DebugCmdError -> Doc ann
-renderDebugCmdError DebugCmdFailed = "Debug command failed"
+  DebugTransactionViewCmd cmd -> firstExceptT DebugTxCmdError $ runTransactionViewCmd cmd
diff --git a/cardano-cli/src/Cardano/CLI/Run/Debug/TransactionView.hs b/cardano-cli/src/Cardano/CLI/Run/Debug/TransactionView.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Cardano.CLI.Run.Debug.TransactionView
+  ( runTransactionViewCmd
+  )
+where
+
+import           Cardano.Api
+
+import           Cardano.CLI.Commands.Debug.TransactionView
+import           Cardano.CLI.Json.Friendly (friendlyTx, friendlyTxBody,
+                   viewOutputFormatToFriendlyFormat)
+import           Cardano.CLI.Read
+import           Cardano.CLI.Types.Common
+import           Cardano.CLI.Types.Errors.TxCmdError
+
+import           Data.Function ((&))
+
+runTransactionViewCmd
+  :: ()
+  => TransactionViewCmdArgs
+  -> ExceptT TxCmdError IO ()
+runTransactionViewCmd
+  TransactionViewCmdArgs
+    { outputFormat
+    , mOutFile
+    , inputTxBodyOrTxFile
+    } =
+    case inputTxBodyOrTxFile of
+      InputTxBodyFile (File txbodyFilePath) -> do
+        txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
+        unwitnessed <-
+          firstExceptT TxCmdTextEnvCddlError . newExceptT $
+            readFileTxBody txbodyFile
+        InAnyShelleyBasedEra era txbody <- pure $ unIncompleteCddlTxBody unwitnessed
+        -- Why are we differentiating between a transaction body and a transaction?
+        -- In the case of a transaction body, we /could/ simply call @makeSignedTransaction []@
+        -- to get a transaction which would allow us to reuse friendlyTxBS. However,
+        -- this would mean that we'd have an empty list of witnesses mentioned in the output, which
+        -- is arguably not part of the transaction body.
+        firstExceptT TxCmdWriteFileError . newExceptT $
+          friendlyTxBody (viewOutputFormatToFriendlyFormat outputFormat) mOutFile (toCardanoEra era) txbody
+      InputTxFile (File txFilePath) -> do
+        txFile <- liftIO $ fileOrPipe txFilePath
+        InAnyShelleyBasedEra era tx <- lift (readFileTx txFile) & onLeft (left . TxCmdTextEnvCddlError)
+        firstExceptT TxCmdWriteFileError . newExceptT $
+          friendlyTx (viewOutputFormatToFriendlyFormat outputFormat) mOutFile (toCardanoEra era) tx
diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/DebugCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/DebugCmdError.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Cardano.CLI.Types.Errors.DebugCmdError
+  ( DebugCmdError (..)
+  )
+where
+
+import           Cardano.Api
+
+import           Cardano.CLI.Types.Errors.TxCmdError
+
+data DebugCmdError
+  = DebugCmdFailed
+  | DebugTxCmdError !TxCmdError
+
+instance Error DebugCmdError where
+  prettyError = \case
+    DebugCmdFailed -> "Debug command failed"
+    DebugTxCmdError err -> renderTxCmdError err