content: {-# LANGUAGE NoImplicitPrelude     #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE OverloadedRecordDot   #-}
  {-# LANGUAGE OverloadedStrings     #-}
  
  {-|
  Module      : Stack.Runners
  Description : Utilities for running stack commands.
  License     : BSD-3-Clause
  
  Utilities for running stack commands.
  
  Instead of using Has-style classes below, the type signatures use concrete
  environments to try and avoid accidentally rerunning configuration parsing. For
  example, we want @withConfig $ withConfig $ ...@ to fail.
  -}
  
  module Stack.Runners
    ( withBuildConfig
    , withEnvConfig
    , withDefaultEnvConfig
    , withConfig
    , withGlobalProject
    , withRunnerGlobal
    , ShouldReexec (..)
    ) where
  
  import qualified Data.ByteString.Lazy.Char8 as L8
  import           RIO.Process
                     ( findExecutable, mkDefaultProcessContext, proc
                     , readProcess
                     )
  import           RIO.Time ( addUTCTime, getCurrentTime )
  import           Stack.Build.Target ( NeedTargets (..) )
  import           Stack.Config
                     ( getInContainer, getInNixShell, loadConfig, withBuildConfig
                     , withNewLogFunc
                     )
  import           Stack.Constants
                     ( defaultTerminalWidth, maxTerminalWidth, minTerminalWidth
                     , nixProgName
                     )
  import           Stack.DefaultColorWhen ( defaultColorWhen )
  import qualified Stack.Docker as Docker
  import qualified Stack.Nix as Nix
  import           Stack.Prelude
  import           Stack.Setup ( setupEnv )
  import           Stack.Storage.User ( logUpgradeCheck, upgradeChecksSince )
  import           Stack.Types.BuildOptsCLI
                     ( BuildOptsCLI, defaultBuildOptsCLI )
  import           Stack.Types.ColorWhen ( ColorWhen (..) )
  import           Stack.Types.Config ( Config (..) )
  import           Stack.Types.ConfigMonoid ( ConfigMonoid (..) )
  import           Stack.Types.Docker ( DockerOpts (..) )
  import           Stack.Types.EnvConfig ( EnvConfig )
  import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
  import           Stack.Types.Nix ( NixOpts (..) )
  import           Stack.Types.Runner
                     ( Runner (..), globalOptsL, reExecL, stackYamlLocL )
  import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
  import           Stack.Types.Version
                     ( minorVersion, stackMinorVersion, stackVersion )
  import           System.Console.ANSI ( hNowSupportsANSI )
  import           System.Terminal ( getTerminalWidth )
  
  -- | Type representing exceptions thrown by functions exported by the
  -- "Stack.Runners" module.
  data RunnersException
    = CommandInvalid
    | DockerAndNixInvalid
    | NixWithinDockerInvalid
    | DockerWithinNixInvalid
    deriving Show
  
  instance Exception RunnersException where
    displayException CommandInvalid =
      "Error: [S-7144]\n"
      ++ "Cannot use this command with options which override the stack.yaml \
         \location."
    displayException DockerAndNixInvalid =
      "Error: [S-8314]\n"
      ++ "Cannot use both Docker and Nix at the same time."
    displayException NixWithinDockerInvalid =
      "Error: [S-8641]\n"
      ++ "Cannot use Nix from within a Docker container."
    displayException DockerWithinNixInvalid =
      "Error: [S-5107]\n"
      ++ "Cannot use Docker from within a Nix shell."
  
  -- | Ensure that no project settings are used when running 'withConfig'.
  withGlobalProject :: RIO Runner a -> RIO Runner a
  withGlobalProject inner = view stackYamlLocL >>= \case
    SYLDefault -> local (set stackYamlLocL SYLGlobalProject) inner
    _ -> throwIO CommandInvalid
  
  -- | Helper for 'withEnvConfig' which passes in some default arguments:
  --
  -- * No targets are requested
  --
  -- * Default command line build options are assumed
  withDefaultEnvConfig :: RIO EnvConfig a -> RIO Config a
  withDefaultEnvConfig = withEnvConfig AllowNoTargets defaultBuildOptsCLI
  
  -- | Upgrade a t'Config' environment to an 'EnvConfig' environment by performing
  -- further parsing of project-specific configuration (like 'withBuildConfig')
  -- and then setting up a build environment toolchain. This is intended to be run
  -- inside a call to 'withConfig'.
  withEnvConfig ::
       NeedTargets
    -> BuildOptsCLI
    -> RIO EnvConfig a
    -- ^ Action that uses the build config.  If Docker is enabled for builds,
    -- this will be run in a Docker container.
    -> RIO Config a
  withEnvConfig needTargets boptsCLI inner =
    withBuildConfig $ do
      envConfig <- setupEnv needTargets boptsCLI Nothing
      logDebug "Starting to execute command inside EnvConfig"
      runRIO envConfig inner
  
  -- | If the settings justify it, should we reexec inside Docker or Nix?
  data ShouldReexec
    = YesReexec
    | NoReexec
  
  -- | Load the configuration. Convenience function used
  -- throughout this module.
  withConfig :: ShouldReexec -> RIO Config a -> RIO Runner a
  withConfig shouldReexec inner =
    loadConfig $ \config -> do
      -- If we have been relaunched in a Docker container, perform in-container
      -- initialization (switch UID, etc.).  We do this after first loading the
      -- configuration since it must happen ASAP but needs a configuration.
      view (globalOptsL . to (.dockerEntrypoint)) >>=
        traverse_ (Docker.entrypoint config)
      runRIO config $ do
        -- Catching all exceptions here, since we don't want this
        -- check to ever cause Stack to stop working
        shouldUpgradeCheck `catchAny` \e ->
          logError $
            "Error: [S-7353]\n" <>
            "Error when running shouldUpgradeCheck: " <>
            displayShow e
        case shouldReexec of
          YesReexec -> reexec inner
          NoReexec -> inner
  
  -- | Perform a Docker or Nix reexec, if warranted. Otherwise run the inner
  -- action.
  reexec :: RIO Config a -> RIO Config a
  reexec inner = do
    nixEnable' <- asks $ (.nix.enable)
    notifyIfNixOnPath <- asks (.notifyIfNixOnPath)
    when (not nixEnable' && notifyIfNixOnPath) $
      findExecutable nixProgName >>= \case
        Left _ -> pure ()
        Right nix -> proc nix ["--version"] $ \pc -> do
          let nixProgName' = style Shell (fromString nixProgName)
              muteMsg = fillSep
                [ flow "To mute this message in future, set"
                , style Shell (flow "notify-if-nix-on-path: false")
                , flow "in Stack's configuration."
                ]
              reportErr errMsg = prettyWarn $
                   fillSep
                     [ nixProgName'
                     , flow "is on the PATH"
                     , parens (fillSep ["at", style File (fromString nix)])
                     , flow "but Stack encountered the following error with"
                     , nixProgName'
                     , style Shell "--version" <> ":"
                     ]
                <> blankLine
                <> errMsg
                <> blankLine
                <> muteMsg
                <> line
          tryAny (readProcess pc) >>= \case
            Left e -> reportErr (ppException e)
            Right (ec, out, err) -> case ec of
              ExitFailure _ -> reportErr $ string (L8.unpack err)
              ExitSuccess -> do
                let trimFinalNewline str = case reverse str of
                      '\n' : rest -> reverse rest
                      _ -> str
                prettyWarn $ fillSep
                     [ fromString (trimFinalNewline $ L8.unpack out)
                     , flow "is on the PATH"
                     , parens (fillSep ["at", style File (fromString nix)])
                     , flow "but Stack's Nix integration is disabled."
                     , muteMsg
                     ]
                  <> line
    dockerEnable' <- asks (.docker.enable)
    case (nixEnable', dockerEnable') of
      (True, True) -> throwIO DockerAndNixInvalid
      (False, False) -> inner
  
      -- Want to use Nix
      (True, False) -> do
        whenM getInContainer $ throwIO NixWithinDockerInvalid
        isReexec <- view reExecL
        if isReexec
        then inner
        else Nix.runShellAndExit
  
      -- Want to use Docker
      (False, True) -> do
        whenM getInNixShell $ throwIO DockerWithinNixInvalid
        inContainer <- getInContainer
        if inContainer
          then do
            isReexec <- view reExecL
            if isReexec
              then inner
              else throwIO Docker.OnlyOnHostException
          else Docker.runContainerAndExit
  
  -- | Use the t'GlobalOpts' to create a t'Runner' and run the provided
  -- action.
  withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
  withRunnerGlobal go inner = do
    useColor <-
      maybe defaultColorWhen pure (getFirst go.configMonoid.colorWhen) >>= \case
        ColorNever -> pure False
        ColorAlways -> pure True
        ColorAuto -> hNowSupportsANSI stderr
    termWidth <- clipWidth <$> maybe
      (fromMaybe defaultTerminalWidth <$> getTerminalWidth)
      pure
      go.termWidthOpt
    menv <- mkDefaultProcessContext
    -- MVar used to ensure the Docker entrypoint is performed exactly once.
    dockerEntrypointMVar <- newMVar False
    let update = go.stylesUpdate
    withNewLogFunc go useColor update $ \logFunc ->
      runRIO Runner
        { globalOpts = go
        , useColor = useColor
        , logFunc = logFunc
        , termWidth = termWidth
        , processContext = menv
        , dockerEntrypointMVar = dockerEntrypointMVar
        } inner
   where
    clipWidth w
      | w < minTerminalWidth = minTerminalWidth
      | w > maxTerminalWidth = maxTerminalWidth
      | otherwise = w
  
  -- | Check if we should recommend upgrading Stack and, if so, recommend it.
  shouldUpgradeCheck :: RIO Config ()
  shouldUpgradeCheck = do
    config <- ask
    when config.recommendStackUpgrade $ do
      now <- getCurrentTime
      let yesterday = addUTCTime (-(24 * 60 * 60)) now
      checks <- upgradeChecksSince yesterday
      when (checks == 0) $ do
        mversion <-
          getLatestHackageVersion NoRequireHackageIndex "stack" UsePreferredVersions
        case mversion of
          -- Compare the minor version so we avoid patch-level, Hackage-only releases.
          -- See: https://github.com/commercialhaskell/stack/pull/4729#pullrequestreview-227176315
          Just (PackageIdentifierRevision _ version _) | minorVersion version > stackMinorVersion -> do
            prettyWarn $
                 fillSep
                   [ flow "You are currently using Stack version"
                   , fromString (versionString stackVersion)
                   , flow "but version"
                   , fromString (versionString version)
                   , flow "is available."
                   ]
              <> blankLine
              <> fillSep
                   [ "You can try to upgrade by running"
                   , style Shell (flow "stack upgrade")
                   ]
              <> blankLine
              <> fillSep
                   [ flow "Tired of seeing this? Add"
                   , style Shell (flow "recommend-stack-upgrade: false")
                   , "to"
                   , pretty config.userGlobalConfigFile <> "."
                   ]
              <> blankLine
          _ -> pure ()
        logUpgradeCheck now
  