{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Dispatch for running all the CLI commands
module Cardano.CLI.Run
  ( ClientCommand (..)
  , ClientCommandErrors
  , renderClientCommandError
  , runClientCommand
  )
where

import Cardano.Api

import Cardano.CLI.Byron.Run
  ( ByronClientCmdError
  , renderByronClientCmdError
  , runByronClientCommand
  )
import Cardano.CLI.Command
import Cardano.CLI.Compatible.Command
import Cardano.CLI.Compatible.Run
import Cardano.CLI.EraBased.Command
import Cardano.CLI.EraBased.Query.Run
import Cardano.CLI.EraBased.Run
import Cardano.CLI.EraIndependent.Address.Run
import Cardano.CLI.EraIndependent.Debug.Run
import Cardano.CLI.EraIndependent.Hash.Run (runHashCmds)
import Cardano.CLI.EraIndependent.Key.Run
import Cardano.CLI.EraIndependent.Node.Run
import Cardano.CLI.EraIndependent.Ping.Run
  ( PingClientCmdError (..)
  , renderPingClientCmdError
  , runPingCmd
  )
import Cardano.CLI.Legacy.Command
import Cardano.CLI.Legacy.Run (runLegacyCmds)
import Cardano.CLI.Render (customRenderHelp, renderAnyCmdError)
import Cardano.CLI.Type.Error.AddressCmdError
import Cardano.CLI.Type.Error.CmdError
import Cardano.CLI.Type.Error.HashCmdError
import Cardano.CLI.Type.Error.KeyCmdError
import Cardano.CLI.Type.Error.NodeCmdError
import Cardano.CLI.Type.Error.QueryCmdError
import Cardano.Git.Rev (gitRev)

import RIO

import Data.List qualified as L
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Version (showVersion)
import Options.Applicative.Help.Core
import Options.Applicative.Types
  ( OptReader (..)
  , Option (..)
  , Parser (..)
  , ParserInfo (..)
  , ParserPrefs (..)
  )
import System.IO qualified as IO
import System.Info (arch, compilerName, compilerVersion, os)

import Paths_cardano_cli (version)

data ClientCommandErrors
  = ByronClientError ByronClientCmdError
  | AddressCmdError AddressCmdError
  | CmdError Text CmdError
  | BackwardCompatibleError
      Text
      -- ^ Command that was run
      SomeException
      -- ^ An exception that was thrown
  | HashCmdError HashCmdError
  | KeyCmdError KeyCmdError
  | NodeCmdError NodeCmdError
  | QueryCmdError QueryCmdError
  | PingClientError PingClientCmdError
  | DebugCmdError DebugCmdError

runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand = \case
  AnyEraCommand AnyEraCommand
cmds ->
    (CmdError -> ClientCommandErrors)
-> ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (Text -> CmdError -> ClientCommandErrors
CmdError (AnyEraCommand -> Text
renderAnyEraCommand AnyEraCommand
cmds)) (ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ AnyEraCommand -> ExceptT CmdError IO ()
runAnyEraCommand AnyEraCommand
cmds
  AddressCommand AddressCmds
cmds ->
    (AddressCmdError -> ClientCommandErrors)
-> ExceptT AddressCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT AddressCmdError -> ClientCommandErrors
AddressCmdError (ExceptT AddressCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT AddressCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ AddressCmds -> ExceptT AddressCmdError IO ()
runAddressCmds AddressCmds
cmds
  NodeCommands NodeCmds
cmds ->
    NodeCmds -> ExceptT NodeCmdError IO ()
runNodeCmds NodeCmds
cmds
      ExceptT NodeCmdError IO ()
-> (ExceptT NodeCmdError IO ()
    -> ExceptT ClientCommandErrors IO ())
-> ExceptT ClientCommandErrors IO ()
forall a b. a -> (a -> b) -> b
& (NodeCmdError -> ClientCommandErrors)
-> ExceptT NodeCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT NodeCmdError -> ClientCommandErrors
NodeCmdError
  ByronCommand ByronCommand
cmds ->
    (ByronClientCmdError -> ClientCommandErrors)
-> ExceptT ByronClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronClientCmdError -> ClientCommandErrors
ByronClientError (ExceptT ByronClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT ByronClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ByronCommand -> ExceptT ByronClientCmdError IO ()
runByronClientCommand ByronCommand
cmds
  CompatibleCommands AnyCompatibleCommand
cmd ->
    -- Catch an exception and wrap it in ExceptT error in order to reuse existing error printing
    -- facilities
    -- TODO This needs to be changed in the future to let the top level exception handler handle the
    -- exceptions printing.
    IO (Either ClientCommandErrors ())
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either ClientCommandErrors ())
 -> ExceptT ClientCommandErrors IO ())
-> IO (Either ClientCommandErrors ())
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$
      ()
-> RIO () (Either ClientCommandErrors ())
-> IO (Either ClientCommandErrors ())
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO () (RIO () (Either ClientCommandErrors ())
 -> IO (Either ClientCommandErrors ()))
-> RIO () (Either ClientCommandErrors ())
-> IO (Either ClientCommandErrors ())
forall a b. (a -> b) -> a -> b
$
        RIO () (Either ClientCommandErrors ())
-> (SomeException -> RIO () (Either ClientCommandErrors ()))
-> RIO () (Either ClientCommandErrors ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
          (() -> Either ClientCommandErrors ()
forall a b. b -> Either a b
Right (() -> Either ClientCommandErrors ())
-> RIO () () -> RIO () (Either ClientCommandErrors ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnyCompatibleCommand -> CIO () ()
forall e. AnyCompatibleCommand -> CIO e ()
runAnyCompatibleCommand AnyCompatibleCommand
cmd)
          (Either ClientCommandErrors ()
-> RIO () (Either ClientCommandErrors ())
forall a. a -> RIO () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientCommandErrors ()
 -> RIO () (Either ClientCommandErrors ()))
-> (SomeException -> Either ClientCommandErrors ())
-> SomeException
-> RIO () (Either ClientCommandErrors ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientCommandErrors -> Either ClientCommandErrors ()
forall a b. a -> Either a b
Left (ClientCommandErrors -> Either ClientCommandErrors ())
-> (SomeException -> ClientCommandErrors)
-> SomeException
-> Either ClientCommandErrors ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SomeException -> ClientCommandErrors
BackwardCompatibleError (AnyCompatibleCommand -> Text
renderAnyCompatibleCommand AnyCompatibleCommand
cmd))
  HashCmds HashCmds
cmds ->
    (HashCmdError -> ClientCommandErrors)
-> ExceptT HashCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HashCmdError -> ClientCommandErrors
HashCmdError (ExceptT HashCmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT HashCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ HashCmds -> ExceptT HashCmdError IO ()
runHashCmds HashCmds
cmds
  KeyCommands KeyCmds
cmds ->
    (KeyCmdError -> ClientCommandErrors)
-> ExceptT KeyCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT KeyCmdError -> ClientCommandErrors
KeyCmdError (ExceptT KeyCmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT KeyCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ KeyCmds -> ExceptT KeyCmdError IO ()
runKeyCmds KeyCmds
cmds
  LegacyCmds LegacyCmds
cmds ->
    (CmdError -> ClientCommandErrors)
-> ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (Text -> CmdError -> ClientCommandErrors
CmdError (LegacyCmds -> Text
renderLegacyCommand LegacyCmds
cmds)) (ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT CmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ LegacyCmds -> ExceptT CmdError IO ()
runLegacyCmds LegacyCmds
cmds
  QueryCommands QueryCmds era
cmds ->
    (QueryCmdError -> ClientCommandErrors)
-> ExceptT QueryCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT QueryCmdError -> ClientCommandErrors
QueryCmdError (ExceptT QueryCmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT QueryCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ QueryCmds era -> ExceptT QueryCmdError IO ()
forall era. QueryCmds era -> ExceptT QueryCmdError IO ()
runQueryCmds QueryCmds era
cmds
  CliPingCommand PingCmd
cmds ->
    (PingClientCmdError -> ClientCommandErrors)
-> ExceptT PingClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT PingClientCmdError -> ClientCommandErrors
PingClientError (ExceptT PingClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT PingClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ PingCmd -> ExceptT PingClientCmdError IO ()
runPingCmd PingCmd
cmds
  CliDebugCmds DebugCmds
cmds ->
    (DebugCmdError -> ClientCommandErrors)
-> ExceptT DebugCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT DebugCmdError -> ClientCommandErrors
DebugCmdError (ExceptT DebugCmdError IO () -> ExceptT ClientCommandErrors IO ())
-> ExceptT DebugCmdError IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ DebugCmds -> ExceptT DebugCmdError IO ()
runDebugCmds DebugCmds
cmds
  Help ParserPrefs
pprefs ParserInfo a
allParserInfo ->
    ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
forall a.
ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp ParserPrefs
pprefs ParserInfo a
allParserInfo
  ClientCommand
DisplayVersion ->
    ExceptT ClientCommandErrors IO ()
runDisplayVersion

renderClientCommandError :: ClientCommandErrors -> Doc ann
renderClientCommandError :: forall ann. ClientCommandErrors -> Doc ann
renderClientCommandError = \case
  CmdError Text
cmdText CmdError
err ->
    Text -> CmdError -> Doc ann
forall ann. Text -> CmdError -> Doc ann
renderCmdError Text
cmdText CmdError
err
  ByronClientError ByronClientCmdError
err ->
    ByronClientCmdError -> Doc ann
forall ann. ByronClientCmdError -> Doc ann
renderByronClientCmdError ByronClientCmdError
err
  AddressCmdError AddressCmdError
err ->
    AddressCmdError -> Doc ann
forall ann. AddressCmdError -> Doc ann
renderAddressCmdError AddressCmdError
err
  BackwardCompatibleError Text
cmdText SomeException
err ->
    Text -> (SomeException -> Doc ann) -> SomeException -> Doc ann
forall a ann. Text -> (a -> Doc ann) -> a -> Doc ann
renderAnyCmdError Text
cmdText SomeException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException SomeException
err
  HashCmdError HashCmdError
err ->
    HashCmdError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. HashCmdError -> Doc ann
prettyError HashCmdError
err
  NodeCmdError NodeCmdError
err ->
    NodeCmdError -> Doc ann
forall ann. NodeCmdError -> Doc ann
renderNodeCmdError NodeCmdError
err
  KeyCmdError KeyCmdError
err ->
    KeyCmdError -> Doc ann
forall ann. KeyCmdError -> Doc ann
renderKeyCmdError KeyCmdError
err
  QueryCmdError QueryCmdError
err ->
    QueryCmdError -> Doc ann
forall ann. QueryCmdError -> Doc ann
renderQueryCmdError QueryCmdError
err
  PingClientError PingClientCmdError
err ->
    PingClientCmdError -> Doc ann
forall ann. PingClientCmdError -> Doc ann
renderPingClientCmdError PingClientCmdError
err
  DebugCmdError DebugCmdError
err ->
    DebugCmdError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. DebugCmdError -> Doc ann
prettyError DebugCmdError
err

runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion = do
  IO () -> ExceptT ClientCommandErrors IO ()
forall a. IO a -> ExceptT ClientCommandErrors IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ClientCommandErrors IO ())
-> (Text -> IO ()) -> Text -> ExceptT ClientCommandErrors IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> ExceptT ClientCommandErrors IO ())
-> Text -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"cardano-cli "
      , Version -> Text
renderVersion Version
version
      , Text
" - "
      , String -> Text
Text.pack String
os
      , Text
"-"
      , String -> Text
Text.pack String
arch
      , Text
" - "
      , String -> Text
Text.pack String
compilerName
      , Text
"-"
      , Version -> Text
renderVersion Version
compilerVersion
      , Text
"\ngit rev "
      , $(gitRev)
      ]
 where
  renderVersion :: Version -> Text
renderVersion = String -> Text
Text.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
showVersion

helpAll :: ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll :: forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
progn [String]
rnames ParserInfo a
parserInfo = do
  String -> IO ()
IO.putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ParserHelp -> String
customRenderHelp Int
80 (ParserInfo a -> ParserHelp
usage_help ParserInfo a
parserInfo)
  String -> IO ()
IO.putStrLn String
""
  Parser a -> IO ()
forall a. Parser a -> IO ()
go (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
parserInfo)
 where
  go :: Parser a -> IO ()
  go :: forall a. Parser a -> IO ()
go Parser a
p = case Parser a
p of
    NilP Maybe a
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    OptP Option a
optP -> case Option a -> OptReader a
forall a. Option a -> OptReader a
optMain Option a
optP of
      CmdReader Maybe String
_ [(String, ParserInfo a)]
cs -> do
        [(String, ParserInfo a)]
-> ((String, ParserInfo a) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, ParserInfo a)]
cs (((String, ParserInfo a) -> IO ()) -> IO ())
-> ((String, ParserInfo a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
c, ParserInfo a
subParserInfo) ->
          ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
progn (String
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rnames) ParserInfo a
subParserInfo
      OptReader a
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AltP Parser a
pa Parser a
pb -> Parser a -> IO ()
forall a. Parser a -> IO ()
go Parser a
pa IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser a -> IO ()
forall a. Parser a -> IO ()
go Parser a
pb
    MultP Parser (x -> a)
pf Parser x
px -> Parser (x -> a) -> IO ()
forall a. Parser a -> IO ()
go Parser (x -> a)
pf IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser x -> IO ()
forall a. Parser a -> IO ()
go Parser x
px
    BindP Parser x
pa x -> Parser a
_ -> Parser x -> IO ()
forall a. Parser a -> IO ()
go Parser x
pa
  usage_help :: ParserInfo a -> ParserHelp
usage_help ParserInfo a
i =
    [ParserHelp] -> ParserHelp
forall a. Monoid a => [a] -> a
mconcat
      [ Chunk Doc -> ParserHelp
usageHelp (Doc -> Chunk Doc
forall a. a -> Chunk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> ([String] -> Doc) -> [String] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs -> Parser a -> String -> Doc
forall a. ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i) (String -> Doc) -> ([String] -> String) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
L.unwords ([String] -> Chunk Doc) -> [String] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ String
progn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
reverse [String]
rnames)
      , Chunk Doc -> ParserHelp
descriptionHelp (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoProgDesc ParserInfo a
i)
      ]

runHelp :: ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp :: forall a.
ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp ParserPrefs
pprefs ParserInfo a
allParserInfo = IO () -> ExceptT ClientCommandErrors IO ()
forall a. IO a -> ExceptT ClientCommandErrors IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ClientCommandErrors IO ())
-> IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
"cardano-cli" [] ParserInfo a
allParserInfo