{-# 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 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

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 = 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 RIO Runner StackYamlLoc
-> (StackYamlLoc -> RIO Runner a) -> RIO Runner a
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
  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 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 :: 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 <- NeedTargets
-> BuildOptsCLI -> Maybe StyleDoc -> RIO BuildConfig EnvConfig
setupEnv NeedTargets
needTargets BuildOptsCLI
boptsCLI Maybe StyleDoc
forall a. Maybe a
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 :: 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 (.dockerEntrypoint)) 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.
(HasDockerEntrypointMVar 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
  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
$ (.nix.enable)
  notifyIfNixOnPath <- asks (.notifyIfNixOnPath)
  when (not nixEnable' && notifyIfNixOnPath) $
    findExecutable nixProgName >>= \case
      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 -> RIO Config ()
reportErr StyleDoc
errMsg = 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
                   [ 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
        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) RIO
  Config (Either SomeException (ExitCode, ByteString, ByteString))
-> (Either SomeException (ExitCode, ByteString, ByteString)
    -> RIO Config ())
-> RIO Config ()
forall a b. RIO Config a -> (a -> RIO Config b) -> RIO Config b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left SomeException
e -> StyleDoc -> RIO Config ()
reportErr (SomeException -> StyleDoc
ppException SomeException
e)
          Right (ExitCode
ec, ByteString
out, ByteString
err) -> case ExitCode
ec of
            ExitFailure Int
_ -> StyleDoc -> RIO Config ()
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
  dockerEnable' <- asks (.docker.enable)
  case (nixEnable', 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
      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 isReexec
      then inner
      else 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
      inContainer <- RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
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 :: forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
go RIO Runner a
inner = do
  useColor <-
    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 (First ColorWhen -> Maybe ColorWhen
forall a. First a -> Maybe a
getFirst GlobalOpts
go.configMonoid.colorWhen) IO ColorWhen -> (ColorWhen -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      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
hNowSupportsANSI Handle
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 = GlobalOpts
go.stylesUpdate
  withNewLogFunc go useColor update $ \LogFunc
logFunc ->
    Runner -> RIO Runner a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Runner
      { globalOpts :: GlobalOpts
globalOpts = GlobalOpts
go
      , useColor :: Bool
useColor = Bool
useColor
      , logFunc :: LogFunc
logFunc = LogFunc
logFunc
      , termWidth :: Int
termWidth = Int
termWidth
      , processContext :: ProcessContext
processContext = ProcessContext
menv
      , dockerEntrypointMVar :: MVar Bool
dockerEntrypointMVar = MVar Bool
dockerEntrypointMVar
      } 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 <- RIO Config Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  when config.recommendStackUpgrade $ do
    now <- getCurrentTime
    let 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
    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 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
config.userGlobalConfigFile 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 ()
      logUpgradeCheck now