{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack
Description : Main Stack tool entry point.
License     : BSD-3-Clause

Main Stack tool entry point.
-}

module Stack
  ( main
  ) where

import           Control.Monad.Extra ( whenJust )
import           GHC.IO.Encoding ( mkTextEncoding, textEncodingName )
import           Options.Applicative.Builder.Extra ( execExtraHelp )
import           Path ( parseAbsFile )
import           Stack.BuildInfo ( versionString' )
import           Stack.CLI ( commandLineHandler )
import           Stack.Constants ( stackProgName )
import           Stack.Docker ( dockerCmdName, dockerHelpOptName )
import           Stack.Nix ( nixCmdName, nixHelpOptName )
import           Stack.Options.DockerParser ( dockerOptsParser )
import           Stack.Options.GlobalParser ( globalOptsFromMonoid )
import           Stack.Options.NixParser ( nixOptsParser )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withRunnerGlobal )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.Version
                   ( VersionCheck (..), checkVersion, showStackVersion
                   , stackVersion
                   )
import           System.Directory ( getCurrentDirectory )
import           System.Environment ( executablePath, getArgs, getProgName )
import           System.IO ( hGetEncoding, hPutStrLn, hSetEncoding )
import           System.Terminal ( hIsTerminalDeviceOrMinTTY )

-- | Type representing exceptions thrown by functions in the "Stack" module.

data StackException
  = InvalidReExecVersion String String
  deriving Int -> StackException -> ShowS
[StackException] -> ShowS
StackException -> [Char]
(Int -> StackException -> ShowS)
-> (StackException -> [Char])
-> ([StackException] -> ShowS)
-> Show StackException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StackException -> ShowS
showsPrec :: Int -> StackException -> ShowS
$cshow :: StackException -> [Char]
show :: StackException -> [Char]
$cshowList :: [StackException] -> ShowS
showList :: [StackException] -> ShowS
Show

instance Exception StackException where
  displayException :: StackException -> [Char]
displayException (InvalidReExecVersion [Char]
expected [Char]
actual) = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Error: [S-2186]\n"
    , [Char]
"When re-executing '"
    , [Char]
stackProgName
    , [Char]
"' in a container, the incorrect version was found\nExpected: "
    , [Char]
expected
    , [Char]
"; found: "
    , [Char]
actual
    ]

-- | Main Stack tool entry point.

main :: IO ()
main :: IO ()
main = do
  -- Line buffer the output by default, particularly for non-terminal runs.

  -- See https://github.com/commercialhaskell/stack/pull/360

  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin  BufferMode
LineBuffering
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
  Handle -> IO ()
hSetTranslit Handle
stdout
  Handle -> IO ()
hSetTranslit Handle
stderr
  args <- IO [[Char]]
getArgs
  progName <- getProgName
  mExecutableFilePath <- fromMaybe (pure Nothing) executablePath
  let mExecutablePath = Maybe [Char]
mExecutableFilePath Maybe [Char]
-> ([Char] -> Maybe (Path Abs File)) -> Maybe (Path Abs File)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile
  isTerminal <- hIsTerminalDeviceOrMinTTY stdout
  execExtraHelp
    args
    dockerHelpOptName
    (dockerOptsParser False)
    ("Only showing --" ++ dockerCmdName ++ "* options.")
  execExtraHelp
    args
    nixHelpOptName
    (nixOptsParser False)
    ("Only showing --" ++ nixCmdName ++ "* options.")
  currentDir <- getCurrentDirectory
  try (commandLineHandler currentDir progName mExecutablePath False) >>= \case
    Left (ExitCode
exitCode :: ExitCode) ->
      ExitCode -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCode
exitCode
    Right (GlobalOptsMonoid
globalMonoid, RIO Runner ()
run) -> do
      global <-
        [Char]
-> Maybe (Path Abs File)
-> Bool
-> GlobalOptsMonoid
-> IO GlobalOpts
forall (m :: * -> *).
MonadIO m =>
[Char]
-> Maybe (Path Abs File)
-> Bool
-> GlobalOptsMonoid
-> m GlobalOpts
globalOptsFromMonoid [Char]
progName Maybe (Path Abs File)
mExecutablePath Bool
isTerminal GlobalOptsMonoid
globalMonoid
      when (global.logLevel == LevelDebug) $
        hPutStrLn stderr versionString'
      whenJust global.reExecVersion $ \[Char]
expectVersion -> do
        expectVersion' <- [Char] -> IO Version
forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing [Char]
expectVersion
        unless (checkVersion MatchMinor expectVersion' stackVersion) $
          throwIO $ InvalidReExecVersion expectVersion showStackVersion
      withRunnerGlobal global $ run `catches`
        [ Handler handleExitCode
        , Handler handlePrettyException
        , Handler handlePantryException
        , Handler handleSomeException
        ]

-- | Change the character encoding of the given Handle to transliterate on

-- unsupported characters instead of throwing an exception

hSetTranslit :: Handle -> IO ()
hSetTranslit :: Handle -> IO ()
hSetTranslit Handle
h = do
  menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  whenJust (fmap textEncodingName menc) $ \[Char]
name ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
'/' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
name) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      enc' <- [Char] -> IO TextEncoding
mkTextEncoding ([Char] -> IO TextEncoding) -> [Char] -> IO TextEncoding
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"//TRANSLIT"
      hSetEncoding h enc'

-- | Handle ExitCode exceptions.

handleExitCode :: ExitCode -> RIO Runner a
handleExitCode :: forall a. ExitCode -> RIO Runner a
handleExitCode = ExitCode -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith

-- | Handle PrettyException exceptions.

handlePrettyException :: PrettyException -> RIO Runner a
handlePrettyException :: forall a. PrettyException -> RIO Runner a
handlePrettyException = PrettyException -> RIO Runner a
forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException

-- | Handle (pretty) PantryException exceptions.

handlePantryException :: PantryException -> RIO Runner a
handlePantryException :: forall a. PantryException -> RIO Runner a
handlePantryException = PantryException -> RIO Runner a
forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException

-- | Handle any pretty exception.

handleAnyPrettyException :: (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException :: forall e a. (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException e
e = do
  -- The code below loads the entire Stack configuration, when all that is

  -- needed are the Stack colours. A tailored approach may be better.

  RIO Runner () -> RIO Runner (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
e) RIO Runner (Either SomeException ())
-> (Either SomeException () -> RIO Runner ()) -> RIO Runner ()
forall a b. RIO Runner a -> (a -> RIO Runner b) -> RIO Runner b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Falls back to the command line's Stack colours if there is any error in

    -- loading the entire Stack configuration.

    Left SomeException
_ -> StyleDoc -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO Runner ()) -> StyleDoc -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
e
    Right ()
_ -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  RIO Runner a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

-- | Handle SomeException exceptions. This special handler stops "stack: " from

-- being printed before the exception.

handleSomeException :: SomeException -> RIO Runner a
handleSomeException :: forall a. SomeException -> RIO Runner a
handleSomeException (SomeException e
e) = do
  Utf8Builder -> RIO Runner ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO Runner ()) -> Utf8Builder -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> [Char] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
e
  RIO Runner a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure