{-# LANGUAGE GADTs #-}

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

import           Cardano.Prelude

import           Control.Monad.Trans.Except.Extra (firstExceptT)
import           Data.String
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import           Cardano.CLI.Byron.Commands (ByronCommand)
import           Cardano.CLI.Byron.Run (ByronClientCmdError, renderByronClientCmdError,
                   runByronClientCommand)
import           Cardano.CLI.Shelley.Commands (ShelleyCommand)
import           Cardano.CLI.Shelley.Run (ShelleyClientCmdError, renderShelleyClientCmdError,
                   runShelleyClientCommand)

import           Cardano.CLI.Render (customRenderHelp)

import           Cardano.Config.Git.Rev (gitRev)
import           Data.Version (showVersion)
import           Paths_cardano_cli (version)
import           System.Info (arch, compilerName, compilerVersion, os)
import           Options.Applicative.Types (Option (..), OptReader (..), Parser (..), ParserInfo (..), ParserPrefs (..))
import           Options.Applicative.Help.Core

import qualified Data.List as L
import qualified System.IO as IO

-- | Sub-commands of 'cardano-cli'.
data ClientCommand =

    -- | Byron Related Commands
    ByronCommand ByronCommand

    -- | Shelley Related Commands
  | ShelleyCommand ShelleyCommand

    -- | Shelley-related commands that have been parsed under the
    -- now-deprecated \"shelley\" subcommand.
  | DeprecatedShelleySubcommand ShelleyCommand

  | forall a. Help ParserPrefs (ParserInfo a)
  | DisplayVersion

data ClientCommandErrors
  = ByronClientError ByronClientCmdError
  | ShelleyClientError ShelleyCommand ShelleyClientCmdError
  deriving Int -> ClientCommandErrors -> ShowS
[ClientCommandErrors] -> ShowS
ClientCommandErrors -> String
(Int -> ClientCommandErrors -> ShowS)
-> (ClientCommandErrors -> String)
-> ([ClientCommandErrors] -> ShowS)
-> Show ClientCommandErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientCommandErrors] -> ShowS
$cshowList :: [ClientCommandErrors] -> ShowS
show :: ClientCommandErrors -> String
$cshow :: ClientCommandErrors -> String
showsPrec :: Int -> ClientCommandErrors -> ShowS
$cshowsPrec :: Int -> ClientCommandErrors -> ShowS
Show

runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand (ByronCommand ByronCommand
c) = (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
c
runClientCommand (ShelleyCommand ShelleyCommand
c) = (ShelleyClientCmdError -> ClientCommandErrors)
-> ExceptT ShelleyClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (ShelleyCommand -> ShelleyClientCmdError -> ClientCommandErrors
ShelleyClientError ShelleyCommand
c) (ExceptT ShelleyClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT ShelleyClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ShelleyCommand -> ExceptT ShelleyClientCmdError IO ()
runShelleyClientCommand ShelleyCommand
c
runClientCommand (DeprecatedShelleySubcommand ShelleyCommand
c) =
  (ShelleyClientCmdError -> ClientCommandErrors)
-> ExceptT ShelleyClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (ShelleyCommand -> ShelleyClientCmdError -> ClientCommandErrors
ShelleyClientError ShelleyCommand
c)
    (ExceptT ShelleyClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT ShelleyClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT ShelleyClientCmdError IO ()
-> ExceptT ShelleyClientCmdError IO ()
forall (m :: * -> *) e.
MonadIO m =>
ExceptT e m () -> ExceptT e m ()
runShelleyClientCommandWithDeprecationWarning
    (ExceptT ShelleyClientCmdError IO ()
 -> ExceptT ShelleyClientCmdError IO ())
-> ExceptT ShelleyClientCmdError IO ()
-> ExceptT ShelleyClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ShelleyCommand -> ExceptT ShelleyClientCmdError IO ()
runShelleyClientCommand ShelleyCommand
c
runClientCommand (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
runClientCommand ClientCommand
DisplayVersion = ExceptT ClientCommandErrors IO ()
runDisplayVersion

renderClientCommandError :: ClientCommandErrors -> Text
renderClientCommandError :: ClientCommandErrors -> Text
renderClientCommandError (ByronClientError ByronClientCmdError
err) =
  ByronClientCmdError -> Text
renderByronClientCmdError ByronClientCmdError
err
renderClientCommandError (ShelleyClientError ShelleyCommand
cmd ShelleyClientCmdError
err) =
  ShelleyCommand -> ShelleyClientCmdError -> Text
renderShelleyClientCmdError ShelleyCommand
cmd ShelleyClientCmdError
err

-- | Combine an 'ExceptT' that will write a warning message to @stderr@ with
-- the provided 'ExceptT'.
ioExceptTWithWarning :: MonadIO m => Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning :: Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning Text
warningMsg ExceptT e m ()
e =
  IO () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr Text
warningMsg) ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT e m ()
e

-- | Used in the event that Shelley-related commands are run using the
-- now-deprecated \"shelley\" subcommand.
runShelleyClientCommandWithDeprecationWarning
  :: MonadIO m
  => ExceptT e m ()
  -> ExceptT e m ()
runShelleyClientCommandWithDeprecationWarning :: ExceptT e m () -> ExceptT e m ()
runShelleyClientCommandWithDeprecationWarning =
    Text -> ExceptT e m () -> ExceptT e m ()
forall (m :: * -> *) e.
MonadIO m =>
Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning Text
warningMsg
  where
    warningMsg :: Text
    warningMsg :: Text
warningMsg =
      Text
"WARNING: The \"shelley\" subcommand is now deprecated and will be "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"removed in the future. Please use the top-level commands instead."

runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion = do
    IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ClientCommandErrors IO ())
-> (Text -> IO ()) -> Text -> ExceptT ClientCommandErrors IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
putTextLn (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 ", Text
gitRev
                ]
  where
    renderVersion :: Version -> Text
renderVersion = String -> Text
Text.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> String
showVersion


helpAll :: ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll :: 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 :: Parser a -> IO ()
go Parser a
p = case Parser a
p of
          NilP Maybe a
_ -> () -> IO ()
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]
cs String -> Maybe (ParserInfo a)
f -> do
              [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
cs ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
c ->
                Maybe (ParserInfo a) -> (ParserInfo a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> Maybe (ParserInfo a)
f String
c) ((ParserInfo a -> IO ()) -> IO ())
-> (ParserInfo a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ParserInfo a
subParserInfo -> 
                  ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
progn (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rnames) ParserInfo a
subParserInfo
            OptReader a
_ -> () -> IO ()
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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> ([String] -> Doc) -> [String] -> Chunk Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 :: ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp ParserPrefs
pprefs ParserInfo a
allParserInfo = IO () -> ExceptT ClientCommandErrors IO ()
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