{-# LANGUAGE BlockArguments #-}

module Hercules.CLI.Main
  ( main,
  )
where

import Data.Version (showVersion)
import Hercules.CLI.Client (prettyPrintHttpErrors)
import qualified Hercules.CLI.Effect as Effect
import qualified Hercules.CLI.Exception as Exception
import qualified Hercules.CLI.Lock as Lock
import qualified Hercules.CLI.Login as Login
import Hercules.CLI.Options (execParser, helper, mkCommand, subparser)
import qualified Hercules.CLI.Secret as Secret
import qualified Hercules.CLI.State as State
import qualified Hercules.CNix
import qualified Hercules.CNix.Exception
import qualified Hercules.CNix.Util
import Hercules.CNix.Verbosity (setShowTrace)
import qualified Language.C.Inline.Cpp.Exception as C
import qualified Options.Applicative as Optparse
import Paths_hercules_ci_cli
import Protolude

main :: IO ()
main :: IO ()
main =
  IO () -> IO ()
forall a. IO a -> IO a
prettyPrintErrors (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall a. IO a -> IO a
Exception.handleUserException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO () -> IO ()
forall a. IO a -> IO a
prettyPrintHttpErrors (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [String]
args <- IO [String]
getArgs
        case [String]
args of
          -- optparse-applicative doesn't allow commands prefixed by `--`.
          [String
"--version"] -> do
            IO ()
exitVersion
          [String]
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ParserInfo (IO ()) -> IO (IO ())
forall a. ParserInfo a -> IO a
execParser ParserInfo (IO ())
opts

initNix :: IO ()
initNix :: IO ()
initNix = do
  IO ()
Hercules.CNix.init
  IO ()
Hercules.CNix.Util.installDefaultSigINTHandler

addNix :: Functor f => f (IO a) -> f (IO a)
addNix :: forall (f :: * -> *) a. Functor f => f (IO a) -> f (IO a)
addNix = (IO a -> IO a) -> f (IO a) -> f (IO a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IO ()
initNix IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)

prettyPrintErrors :: IO a -> IO a
prettyPrintErrors :: forall a. IO a -> IO a
prettyPrintErrors = IO a -> IO a
forall a. IO a -> IO a
handleFinal (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
handleFatal (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
handleRemainingCpp (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
Hercules.CNix.Exception.handleExceptions
  where
    handleFinal :: IO a -> IO a
handleFinal = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle \SomeException
e ->
      case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe ExitCode of
        Just ExitCode
_ -> SomeException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
        Maybe ExitCode
Nothing -> do
          String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"hci: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
          IO a
forall a. IO a
exitFailure
    handleFatal :: IO a -> IO a
handleFatal = (FatalError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle \FatalError
e -> do
      Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: Unexpected exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FatalError -> Text
fatalErrorMessage FatalError
e
      IO a
forall a. IO a
exitFailure
    handleRemainingCpp :: IO a -> IO a
handleRemainingCpp = (CppException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle \case
      C.CppStdException CppExceptionPtr
_ptr ByteString
msg Maybe ByteString
mt -> do
        ByteString -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
putErrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"hci: Unexpected C++ exception: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
msg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString
" of type" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) Maybe ByteString
mt
        IO a
forall a. IO a
exitFailure
      C.CppHaskellException SomeException
actual -> do
        IO a -> IO a
forall a. IO a -> IO a
prettyPrintErrors (SomeException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
actual)
      C.CppNonStdException CppExceptionPtr
_ptr Maybe ByteString
t -> do
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: Unexpected C++ exception of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe ByteString -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Maybe ByteString
t
        IO a
forall a. IO a
exitFailure

opts :: Optparse.ParserInfo (IO ())
opts :: ParserInfo (IO ())
opts =
  Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ())
forall a. Parser a -> InfoMod a -> ParserInfo a
Optparse.info
    (Parser (IO ())
commands Parser (IO ()) -> Parser (IO () -> IO ()) -> Parser (IO ())
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (IO () -> IO ())
forall a. Parser (a -> a)
helper)
    (InfoMod (IO ())
forall a. InfoMod a
Optparse.fullDesc InfoMod (IO ()) -> InfoMod (IO ()) -> InfoMod (IO ())
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.header String
"Command line interface to Hercules CI")

exitVersion :: IO ()
exitVersion :: IO ()
exitVersion = do
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Text
"hci " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ver)
  IO ()
forall a. IO a
exitSuccess
  where
    ver :: Text
ver = String -> Text
forall a b. ConvertText a b => a -> b
toS (Version -> String
showVersion Version
Paths_hercules_ci_cli.version)

setCommonOpts :: Optparse.Parser (IO ())
setCommonOpts :: Parser (IO ())
setCommonOpts =
  IO () -> IO () -> Mod FlagFields (IO ()) -> Parser (IO ())
forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag IO ()
forall (f :: * -> *). Applicative f => f ()
pass (Bool -> IO ()
setShowTrace Bool
True) (String -> Mod FlagFields (IO ())
forall (f :: * -> *) a. HasName f => String -> Mod f a
Optparse.long String
"show-trace" Mod FlagFields (IO ())
-> Mod FlagFields (IO ()) -> Mod FlagFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (IO ())
forall (f :: * -> *) a. String -> Mod f a
Optparse.help String
"Print evaluation stack traces in full")

commands :: Optparse.Parser (IO ())
commands :: Parser (IO ())
commands =
  IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    (IO () -> IO () -> IO ())
-> Parser (IO ()) -> Parser (IO () -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (IO ())
setCommonOpts
    Parser (IO () -> IO ()) -> Parser (IO ()) -> Parser (IO ())
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod CommandFields (IO ()) -> Parser (IO ())
forall a. Mod CommandFields a -> Parser a
subparser
      ( String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          String
"login"
          (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Configure token for authentication to hercules-ci.com")
          Parser (IO ())
Login.commandParser
          Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
            String
"state"
            (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Perform operations on state files")
            Parser (IO ())
State.commandParser
          Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
            String
"version"
            (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Print the command name and version")
            (IO () -> Parser (IO ())
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO ()
exitVersion)
          Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
            String
"effect"
            (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Run effects locally")
            (Parser (IO ()) -> Parser (IO ())
forall (f :: * -> *) a. Functor f => f (IO a) -> f (IO a)
addNix Parser (IO ())
Effect.commandParser)
          Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
            String
"secret"
            (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Manipulate locally stored secrets")
            Parser (IO ())
Secret.commandParser
          Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
            String
"lock"
            (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Opt-in locking for use with state")
            Parser (IO ())
Lock.commandParser
      )