{-# 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.Commands
import           Cardano.CLI.Compatible.Commands
import           Cardano.CLI.Compatible.Run
import           Cardano.CLI.EraBased.Commands.TopLevelCommands
import           Cardano.CLI.EraBased.Run
import           Cardano.CLI.EraBased.Run.Query
import           Cardano.CLI.Legacy.Commands
import           Cardano.CLI.Legacy.Run (runLegacyCmds)
import           Cardano.CLI.Render (customRenderHelp)
import           Cardano.CLI.Run.Address
import           Cardano.CLI.Run.Debug
import           Cardano.CLI.Run.Hash (runHashCmds)
import           Cardano.CLI.Run.Key
import           Cardano.CLI.Run.Node
import           Cardano.CLI.Run.Ping (PingClientCmdError (..), renderPingClientCmdError,
                   runPingCmd)
import           Cardano.CLI.Types.Errors.AddressCmdError
import           Cardano.CLI.Types.Errors.CmdError
import           Cardano.CLI.Types.Errors.HashCmdError
import           Cardano.CLI.Types.Errors.KeyCmdError
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)
import           Options.Applicative.Help.Core
import           Options.Applicative.Types (OptReader (..), Option (..), Parser (..),
                   ParserInfo (..), ParserPrefs (..))
import           System.Info (arch, compilerName, compilerVersion, os)
import qualified System.IO as IO

import           Paths_cardano_cli (version)

data ClientCommandErrors
  = ByronClientError ByronClientCmdError
  | AddressCmdError AddressCmdError
  | CmdError Text CmdError
  | BackwardCompatibleError
      Text
      -- ^ Command that was run
      CompatibleCmdError
  | 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 ->
    (CompatibleCmdError -> ClientCommandErrors)
-> ExceptT CompatibleCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (Text -> CompatibleCmdError -> ClientCommandErrors
BackwardCompatibleError (AnyCompatibleCommand -> Text
renderAnyCompatibleCommand AnyCompatibleCommand
cmd)) (ExceptT CompatibleCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT CompatibleCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$
      AnyCompatibleCommand -> ExceptT CompatibleCmdError IO ()
runAnyCompatibleCommand 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 CompatibleCmdError
err ->
    Text -> CompatibleCmdError -> Doc ann
forall ann. Text -> CompatibleCmdError -> Doc ann
renderCompatibleCmdError Text
cmdText CompatibleCmdError
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