{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 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.BuildOpts
                   ( BuildOptsCLI, defaultBuildOptsCLI )
import           Stack.Types.ColorWhen ( ColorWhen (..) )
import           Stack.Types.Config ( Config (..) )
import           Stack.Types.ConfigMonoid ( ConfigMonoid (..) )
import           Stack.Types.Docker ( dockerEnable )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Nix ( nixEnable )
import           Stack.Types.Runner
                   ( Runner (..), globalOptsL, reExecL, stackYamlLocL )
import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import           Stack.Types.Version
                   ( minorVersion, stackMinorVersion, stackVersion )
import           System.Console.ANSI ( hSupportsANSI )
import           System.Terminal ( getTerminalWidth )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Runners" module.

data RunnersException
  = CommandInvalid
  | DockerAndNixInvalid
  | NixWithinDockerInvalid
  | DockerWithinNixInvalid
  deriving (Int -> RunnersException -> ShowS
[RunnersException] -> ShowS
RunnersException -> String
(Int -> RunnersException -> ShowS)
-> (RunnersException -> String)
-> ([RunnersException] -> ShowS)
-> Show RunnersException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunnersException -> ShowS
showsPrec :: Int -> RunnersException -> ShowS
$cshow :: RunnersException -> String
show :: RunnersException -> String
$cshowList :: [RunnersException] -> ShowS
showList :: [RunnersException] -> ShowS
Show, Typeable)

instance Exception RunnersException where
  displayException :: RunnersException -> String
displayException RunnersException
CommandInvalid =
    String
"Error: [S-7144]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use this command with options which override the stack.yaml \
       \location."
  displayException RunnersException
DockerAndNixInvalid =
    String
"Error: [S-8314]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use both Docker and Nix at the same time."
  displayException RunnersException
NixWithinDockerInvalid =
    String
"Error: [S-8641]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use Nix from within a Docker container."
  displayException RunnersException
DockerWithinNixInvalid =
    String
"Error: [S-5107]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"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 :: forall a. RIO Runner a -> RIO Runner a
withGlobalProject RIO Runner a
inner = do
  StackYamlLoc
oldSYL <- Getting StackYamlLoc Runner StackYamlLoc -> RIO Runner StackYamlLoc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting StackYamlLoc Runner StackYamlLoc
forall env. HasRunner env => Lens' env StackYamlLoc
Lens' Runner StackYamlLoc
stackYamlLocL
  case StackYamlLoc
oldSYL of
    StackYamlLoc
SYLDefault -> (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall a. (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner StackYamlLoc StackYamlLoc
-> StackYamlLoc -> Runner -> Runner
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Runner Runner StackYamlLoc StackYamlLoc
forall env. HasRunner env => Lens' env StackYamlLoc
Lens' Runner StackYamlLoc
stackYamlLocL StackYamlLoc
SYLGlobalProject) RIO Runner a
inner
    StackYamlLoc
_ -> RunnersException -> RIO Runner a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
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 :: forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig = NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
defaultBuildOptsCLI

-- | Upgrade a '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 :: forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
needTargets BuildOptsCLI
boptsCLI RIO EnvConfig a
inner =
  RIO BuildConfig a -> RIO Config a
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig (RIO BuildConfig a -> RIO Config a)
-> RIO BuildConfig a -> RIO Config a
forall a b. (a -> b) -> a -> b
$ do
    EnvConfig
envConfig <- NeedTargets
-> BuildOptsCLI -> Maybe Text -> RIO BuildConfig EnvConfig
setupEnv NeedTargets
needTargets BuildOptsCLI
boptsCLI Maybe Text
forall a. Maybe a
Nothing
    Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Starting to execute command inside EnvConfig"
    EnvConfig -> RIO EnvConfig a -> RIO BuildConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
envConfig RIO EnvConfig a
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 :: forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
shouldReexec RIO Config a
inner =
  (Config -> RIO Runner a) -> RIO Runner a
forall env a.
(HasRunner env, HasTerm env) =>
(Config -> RIO env a) -> RIO env a
loadConfig ((Config -> RIO Runner a) -> RIO Runner a)
-> (Config -> RIO Runner a) -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ \Config
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.

    Getting (Maybe DockerEntrypoint) Runner (Maybe DockerEntrypoint)
-> RIO Runner (Maybe DockerEntrypoint)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((GlobalOpts -> Const (Maybe DockerEntrypoint) GlobalOpts)
-> Runner -> Const (Maybe DockerEntrypoint) Runner
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL((GlobalOpts -> Const (Maybe DockerEntrypoint) GlobalOpts)
 -> Runner -> Const (Maybe DockerEntrypoint) Runner)
-> ((Maybe DockerEntrypoint
     -> Const (Maybe DockerEntrypoint) (Maybe DockerEntrypoint))
    -> GlobalOpts -> Const (Maybe DockerEntrypoint) GlobalOpts)
-> Getting (Maybe DockerEntrypoint) Runner (Maybe DockerEntrypoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> Maybe DockerEntrypoint)
-> SimpleGetter GlobalOpts (Maybe DockerEntrypoint)
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe DockerEntrypoint
globalDockerEntrypoint) RIO Runner (Maybe DockerEntrypoint)
-> (Maybe DockerEntrypoint -> 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
>>=
      (DockerEntrypoint -> RIO Runner ())
-> Maybe DockerEntrypoint -> RIO Runner ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Config -> DockerEntrypoint -> RIO Runner ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
Config -> DockerEntrypoint -> RIO env ()
Docker.entrypoint Config
config)
    Config -> RIO Config a -> RIO Runner a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Config
config (RIO Config a -> RIO Runner a) -> RIO Config a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ do
      -- Catching all exceptions here, since we don't want this

      -- check to ever cause Stack to stop working

      RIO Config ()
shouldUpgradeCheck RIO Config () -> (SomeException -> RIO Config ()) -> RIO Config ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e ->
        Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Error: [S-7353]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
"Error when running shouldUpgradeCheck: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
      case ShouldReexec
shouldReexec of
        ShouldReexec
YesReexec -> RIO Config a -> RIO Config a
forall a. RIO Config a -> RIO Config a
reexec RIO Config a
inner
        ShouldReexec
NoReexec -> RIO Config a
inner

-- | Perform a Docker or Nix reexec, if warranted. Otherwise run the inner

-- action.

reexec :: RIO Config a -> RIO Config a
reexec :: forall a. RIO Config a -> RIO Config a
reexec RIO Config a
inner = do
  Bool
nixEnable' <- (Config -> Bool) -> RIO Config Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Config -> Bool) -> RIO Config Bool)
-> (Config -> Bool) -> RIO Config Bool
forall a b. (a -> b) -> a -> b
$ NixOpts -> Bool
nixEnable (NixOpts -> Bool) -> (Config -> NixOpts) -> Config -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> NixOpts
configNix
  Bool
notifyIfNixOnPath <- (Config -> Bool) -> RIO Config Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> Bool
configNotifyIfNixOnPath
  Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
nixEnable' Bool -> Bool -> Bool
&& Bool
notifyIfNixOnPath) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
    Either ProcessException String
eNix <- String -> RIO Config (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
nixProgName
    case Either ProcessException String
eNix of
      Left ProcessException
_ -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right String
nix -> String
-> [String]
-> (ProcessConfig () () () -> RIO Config ())
-> RIO Config ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
nix [String
"--version"] ((ProcessConfig () () () -> RIO Config ()) -> RIO Config ())
-> (ProcessConfig () () () -> RIO Config ()) -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> do
        let nixProgName' :: StyleDoc
nixProgName' = Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
nixProgName)
            muteMsg :: StyleDoc
muteMsg = [StyleDoc] -> StyleDoc
fillSep
              [ String -> StyleDoc
flow String
"To mute this message in future, set"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"notify-if-nix-on-path: false")
              , String -> StyleDoc
flow String
"in Stack's configuration."
              ]
            reportErr :: StyleDoc -> m ()
reportErr StyleDoc
errMsg = StyleDoc -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
                 [StyleDoc] -> StyleDoc
fillSep
                   [ StyleDoc
nixProgName'
                   , String -> StyleDoc
flow String
"is on the PATH"
                   , StyleDoc -> StyleDoc
parens ([StyleDoc] -> StyleDoc
fillSep [StyleDoc
"at", Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
nix)])
                   , String -> StyleDoc
flow String
"but Stack encountered the following error with"
                   , StyleDoc
nixProgName'
                   , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--version" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                   ]
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
errMsg
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
muteMsg
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        Either SomeException (ExitCode, ByteString, ByteString)
res <- RIO Config (ExitCode, ByteString, ByteString)
-> RIO
     Config (Either SomeException (ExitCode, ByteString, ByteString))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (ProcessConfig () () ()
-> RIO Config (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess ProcessConfig () () ()
pc)
        case Either SomeException (ExitCode, ByteString, ByteString)
res of
          Left SomeException
e -> StyleDoc -> RIO Config ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
reportErr (SomeException -> StyleDoc
ppException SomeException
e)
          Right (ExitCode
ec, ByteString
out, ByteString
err) -> case ExitCode
ec of
            ExitFailure Int
_ -> StyleDoc -> RIO Config ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
reportErr (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
string (ByteString -> String
L8.unpack ByteString
err)
            ExitCode
ExitSuccess -> do
              let trimFinalNewline :: ShowS
trimFinalNewline String
str = case ShowS
forall a. [a] -> [a]
reverse String
str of
                    Char
'\n' : String
rest -> ShowS
forall a. [a] -> [a]
reverse String
rest
                    String
_ -> String
str
              StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
                   [ String -> StyleDoc
forall a. IsString a => String -> a
fromString (ShowS
trimFinalNewline ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L8.unpack ByteString
out)
                   , String -> StyleDoc
flow String
"is on the PATH"
                   , StyleDoc -> StyleDoc
parens ([StyleDoc] -> StyleDoc
fillSep [StyleDoc
"at", Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
nix)])
                   , String -> StyleDoc
flow String
"but Stack's Nix integration is disabled."
                   , StyleDoc
muteMsg
                   ]
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  Bool
dockerEnable' <- (Config -> Bool) -> RIO Config Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Config -> Bool) -> RIO Config Bool)
-> (Config -> Bool) -> RIO Config Bool
forall a b. (a -> b) -> a -> b
$ DockerOpts -> Bool
dockerEnable (DockerOpts -> Bool) -> (Config -> DockerOpts) -> Config -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> DockerOpts
configDocker
  case (Bool
nixEnable', Bool
dockerEnable') of
    (Bool
True, Bool
True) -> RunnersException -> RIO Config a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
DockerAndNixInvalid
    (Bool
False, Bool
False) -> RIO Config a
inner

    -- Want to use Nix

    (Bool
True, Bool
False) -> do
      RIO Config Bool -> RIO Config () -> RIO Config ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ RunnersException -> RIO Config ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
NixWithinDockerInvalid
      Bool
isReexec <- Getting Bool Config Bool -> RIO Config Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Config Bool
forall env. HasRunner env => SimpleGetter env Bool
SimpleGetter Config Bool
reExecL
      if Bool
isReexec
      then RIO Config a
inner
      else RIO Config a
forall void. RIO Config void
Nix.runShellAndExit

    -- Want to use Docker

    (Bool
False, Bool
True) -> do
      RIO Config Bool -> RIO Config () -> RIO Config ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
getInNixShell (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ RunnersException -> RIO Config ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
DockerWithinNixInvalid
      Bool
inContainer <- RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer
      if Bool
inContainer
        then do
          Bool
isReexec <- Getting Bool Config Bool -> RIO Config Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Config Bool
forall env. HasRunner env => SimpleGetter env Bool
SimpleGetter Config Bool
reExecL
          if Bool
isReexec
            then RIO Config a
inner
            else DockerException -> RIO Config a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
Docker.OnlyOnHostException
        else RIO Config a
forall env void. HasConfig env => RIO env void
Docker.runContainerAndExit

-- | Use the 'GlobalOpts' to create a 'Runner' and run the provided

-- action.

withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal :: forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
go RIO Runner a
inner = do
  ColorWhen
colorWhen <-
    IO ColorWhen
-> (ColorWhen -> IO ColorWhen) -> Maybe ColorWhen -> IO ColorWhen
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ColorWhen
defaultColorWhen ColorWhen -> IO ColorWhen
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ColorWhen -> IO ColorWhen)
-> Maybe ColorWhen -> IO ColorWhen
forall a b. (a -> b) -> a -> b
$
    First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst (First ColorWhen -> Maybe ColorWhen)
-> First ColorWhen -> Maybe ColorWhen
forall a b. (a -> b) -> a -> b
$ ConfigMonoid -> First ColorWhen
configMonoidColorWhen (ConfigMonoid -> First ColorWhen)
-> ConfigMonoid -> First ColorWhen
forall a b. (a -> b) -> a -> b
$ GlobalOpts -> ConfigMonoid
globalConfigMonoid GlobalOpts
go
  Bool
useColor <- case ColorWhen
colorWhen of
    ColorWhen
ColorNever -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    ColorWhen
ColorAlways -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    ColorWhen
ColorAuto -> Handle -> IO Bool
hSupportsANSI Handle
stderr
  Int
termWidth <- Int -> Int
clipWidth (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultTerminalWidth
                                    (Maybe Int -> Int) -> IO (Maybe Int) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Int)
getTerminalWidth)
                                   Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalOpts -> Maybe Int
globalTermWidth GlobalOpts
go)
  ProcessContext
menv <- IO ProcessContext
forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext
  let update :: StylesUpdate
update = GlobalOpts -> StylesUpdate
globalStylesUpdate GlobalOpts
go
  GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor StylesUpdate
update ((LogFunc -> IO a) -> IO a) -> (LogFunc -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> Runner -> RIO Runner a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Runner
    { runnerGlobalOpts :: GlobalOpts
runnerGlobalOpts = GlobalOpts
go
    , runnerUseColor :: Bool
runnerUseColor = Bool
useColor
    , runnerLogFunc :: LogFunc
runnerLogFunc = LogFunc
logFunc
    , runnerTermWidth :: Int
runnerTermWidth = Int
termWidth
    , runnerProcessContext :: ProcessContext
runnerProcessContext = ProcessContext
menv
    } RIO Runner a
inner
 where
  clipWidth :: Int -> Int
clipWidth Int
w
    | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minTerminalWidth = Int
minTerminalWidth
    | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTerminalWidth = Int
maxTerminalWidth
    | Bool
otherwise = Int
w

-- | Check if we should recommend upgrading Stack and, if so, recommend it.

shouldUpgradeCheck :: RIO Config ()
shouldUpgradeCheck :: RIO Config ()
shouldUpgradeCheck = do
  Config
config <- RIO Config Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configRecommendUpgrade Config
config) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- RIO Config UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
    let yesterday :: UTCTime
yesterday = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60) UTCTime
now
    Int
checks <- UTCTime -> RIO Config Int
forall env. HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince UTCTime
yesterday
    Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
checks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe PackageIdentifierRevision
mversion <- RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO Config (Maybe PackageIdentifierRevision)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion RequireHackageIndex
NoRequireHackageIndex PackageName
"stack" UsePreferredVersions
UsePreferredVersions
      case Maybe PackageIdentifierRevision
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 PackageName
_ Version
version CabalFileInfo
_) | Version -> Version
minorVersion Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
stackMinorVersion -> do
          StyleDoc -> RIO Config ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO Config ()) -> StyleDoc -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
               [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"You are currently using Stack version"
                 , String -> StyleDoc
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
stackVersion)
                 , String -> StyleDoc
flow String
"but version"
                 , String -> StyleDoc
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
version)
                 , String -> StyleDoc
flow String
"is available."
                 ]
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                 [ StyleDoc
"You can try to upgrade by running"
                 , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack upgrade")
                 ]
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"Tired of seeing this? Add"
                 , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"recommend-stack-upgrade: false")
                 , StyleDoc
"to"
                 , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (Config -> Path Abs File
configUserConfigPath Config
config) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                 ]
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        Maybe PackageIdentifierRevision
_ -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      UTCTime -> RIO Config ()
forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
now