stack-2.15.1: src/Stack.hs

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

-- | Main Stack tool entry point.

module Stack
  ( main
  ) where

import           GHC.IO.Encoding ( mkTextEncoding, textEncodingName )
import           Options.Applicative.Builder.Extra ( execExtraHelp )
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 ( 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 (Show, Typeable)

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

main :: IO ()
main = do
  -- Line buffer the output by default, particularly for non-terminal runs.
  -- See https://github.com/commercialhaskell/stack/pull/360
  hSetBuffering stdout LineBuffering
  hSetBuffering stdin  LineBuffering
  hSetBuffering stderr LineBuffering
  hSetTranslit stdout
  hSetTranslit stderr
  args <- getArgs
  progName <- getProgName
  isTerminal <- hIsTerminalDeviceOrMinTTY stdout
  execExtraHelp
    args
    dockerHelpOptName
    (dockerOptsParser False)
    ("Only showing --" ++ dockerCmdName ++ "* options.")
  execExtraHelp
    args
    nixHelpOptName
    (nixOptsParser False)
    ("Only showing --" ++ nixCmdName ++ "* options.")
  currentDir <- getCurrentDirectory
  eGlobalRun <- try $ commandLineHandler currentDir progName False
  case eGlobalRun of
    Left (exitCode :: ExitCode) ->
      throwIO exitCode
    Right (globalMonoid, run) -> do
      global <- globalOptsFromMonoid isTerminal globalMonoid
      when (global.logLevel == LevelDebug) $
        hPutStrLn stderr versionString'
      case global.reExecVersion of
        Just expectVersion -> do
          expectVersion' <- parseVersionThrowing expectVersion
          unless (checkVersion MatchMinor expectVersion' stackVersion) $
            throwIO $
              InvalidReExecVersion expectVersion showStackVersion
        _ -> pure ()
      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 h = do
  menc <- hGetEncoding h
  case fmap textEncodingName menc of
    Just name
      | '/' `notElem` name -> do
          enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
          hSetEncoding h enc'
    _ -> pure ()

-- | Handle ExitCode exceptions.
handleExitCode :: ExitCode -> RIO Runner a
handleExitCode = exitWith

-- | Handle PrettyException exceptions.
handlePrettyException :: PrettyException -> RIO Runner a
handlePrettyException = handleAnyPrettyException

-- | Handle (pretty) PantryException exceptions.
handlePantryException :: PantryException -> RIO Runner a
handlePantryException = handleAnyPrettyException

-- | Handle any pretty exception.
handleAnyPrettyException :: (Exception e, Pretty e) => e -> RIO Runner a
handleAnyPrettyException 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.
  result <- tryAny $ withConfig NoReexec $ prettyError $ pretty e
  case result of
    -- Falls back to the command line's Stack colours if there is any error in
    -- loading the entire Stack configuration.
    Left _ -> prettyError $ pretty e
    Right _ -> pure ()
  exitFailure

-- | Handle SomeException exceptions. This special handler stops "stack: " from
-- being printed before the exception.
handleSomeException :: SomeException -> RIO Runner a
handleSomeException (SomeException e) = do
  logError $ fromString $ displayException e
  exitFailure