WIP

IntersectMBO · Oct 7, 2024 · fe6db73 · fe6db73
1 parent bda0cb3
commit fe6db73
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 2 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Commands.hs b/cardano-cli/src/Cardano/CLI/Commands.hs
@@ -10,6 +10,7 @@ import           Cardano.CLI.Commands.Debug
 import           Cardano.CLI.Commands.Hash (HashCmds)
 import           Cardano.CLI.Commands.Ping (PingCmd (..))
 import           Cardano.CLI.EraBased.Commands
+import           Cardano.CLI.EraBased.Commands.Node
 import           Cardano.CLI.Legacy.Commands
 
 import           Options.Applicative.Types (ParserInfo (..), ParserPrefs (..))
@@ -21,6 +22,8 @@ data ClientCommand
     ByronCommand ByronCommand
   | -- | Era-agnostic hashing commands
     HashCmds HashCmds
+  | -- | Era agnostic node commands
+    NodeCommands NodeCmds
   | -- | Legacy shelley-based Commands
     LegacyCmds LegacyCmds
   | CliPingCommand PingCmd

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs
@@ -54,7 +54,7 @@ data Cmds era
   | KeyCmds (KeyCmds era)
   | GenesisCmds (GenesisCmds era)
   | GovernanceCmds (GovernanceCmds era)
-  | NodeCmds (NodeCmds era)
+  | NodeCmds NodeCmds
   | QueryCmds (QueryCmds era)
   | StakeAddressCmds (StakeAddressCmds era)
   | StakePoolCmds (StakePoolCmds era)

diff --git a/cardano-cli/src/Cardano/CLI/Options.hs b/cardano-cli/src/Cardano/CLI/Options.hs
@@ -9,10 +9,13 @@ module Cardano.CLI.Options
   )
 where
 
+import           Cardano.Api (ShelleyBasedEra (..))
+
 import           Cardano.CLI.Byron.Parsers (backwardsCompatibilityCommands, parseByronCommands)
 import           Cardano.CLI.Environment (EnvCli)
 import           Cardano.CLI.EraBased.Commands
 import           Cardano.CLI.EraBased.Options.Common
+import           Cardano.CLI.EraBased.Options.Node
 import           Cardano.CLI.Legacy.Options (parseLegacyCmds)
 import           Cardano.CLI.Options.Debug
 import           Cardano.CLI.Options.Hash
@@ -47,13 +50,21 @@ pref =
       , helpRenderHelp customRenderHelp
       ]
 
+-- The node related commands are shelley era agnostic for the time being.
+-- There is no need to guard them by the era argument.
+nodeCmdsTopLevel :: Parser ClientCommand
+nodeCmdsTopLevel =
+  AnyEraCommand . AnyEraCommandOf ShelleyBasedEraShelley . NodeCmds <$> pNodeCmds
+
+-- fmap (AnyEraCommand . AnyEraCommandOf ShelleyBasedEraShelley . NodeCmds) pNodeCmds
 parseClientCommand :: EnvCli -> Parser ClientCommand
 parseClientCommand envCli =
   asum
     -- There are name clashes between Shelley commands and the Byron backwards
     -- compat commands (e.g. "genesis"), and we need to prefer the Shelley ones
     -- so we list it first.
-    [ parseLegacy envCli
+    [ nodeCmdsTopLevel
+    , parseLegacy envCli
     , parseByron envCli
     , parseAnyEra envCli
     , parseHash

diff --git a/cardano-cli/src/Cardano/CLI/Run.hs b/cardano-cli/src/Cardano/CLI/Run.hs
@@ -18,6 +18,7 @@ import           Cardano.CLI.Byron.Run (ByronClientCmdError, renderByronClientCm
 import           Cardano.CLI.Commands
 import           Cardano.CLI.EraBased.Commands
 import           Cardano.CLI.EraBased.Run
+import           Cardano.CLI.EraBased.Run.Node
 import           Cardano.CLI.Legacy.Commands
 import           Cardano.CLI.Legacy.Run (runLegacyCmds)
 import           Cardano.CLI.Render (customRenderHelp)
@@ -27,9 +28,11 @@ import           Cardano.CLI.Run.Ping (PingClientCmdError (..), renderPingClient
                    runPingCmd)
 import           Cardano.CLI.Types.Errors.CmdError
 import           Cardano.CLI.Types.Errors.HashCmdError
+import           Cardano.CLI.Types.Errors.NodeCmdError
 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
@@ -47,13 +50,17 @@ data ClientCommandErrors
   = ByronClientError ByronClientCmdError
   | CmdError Text CmdError
   | HashCmdError HashCmdError
+  | NodeCmdError NodeCmdError
   | PingClientError PingClientCmdError
   | DebugCmdError DebugCmdError
 
 runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
 runClientCommand = \case
   AnyEraCommand cmds ->
     firstExceptT (CmdError (renderAnyEraCommand cmds)) $ runAnyEraCommand cmds
+  NodeCommands cmds ->
+    runNodeCmds cmds
+      & firstExceptT NodeCmdError
   ByronCommand cmds ->
     firstExceptT ByronClientError $ runByronClientCommand cmds
   HashCmds cmds ->
@@ -77,6 +84,8 @@ renderClientCommandError = \case
     renderByronClientCmdError err
   HashCmdError err ->
     prettyError err
+  NodeCmdError err ->
+    renderNodeCmdError err
   PingClientError err ->
     renderPingClientCmdError err
   DebugCmdError err ->