{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# 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           Stack.Prelude
import           RIO.Process (mkDefaultProcessContext)
import           RIO.Time (addUTCTime, getCurrentTime)
import           Stack.Build.Target(NeedTargets(..))
import           Stack.Config
import           Stack.Constants
import           Stack.DefaultColorWhen (defaultColorWhen)
import qualified Stack.Docker as Docker
import qualified Stack.Nix as Nix
import           Stack.Setup
import           Stack.Storage.User (upgradeChecksSince, logUpgradeCheck)
import           Stack.Types.Config
import           Stack.Types.Docker (dockerEnable)
import           Stack.Types.Nix (nixEnable)
import           Stack.Types.Version (stackMinorVersion, minorVersion)
import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
import           System.Terminal (getTerminalWidth)

-- | 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env StackYamlLoc
stackYamlLocL
  case StackYamlLoc
oldSYL of
    StackYamlLoc
SYLDefault -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasRunner env => Lens' env StackYamlLoc
stackYamlLocL StackYamlLoc
SYLGlobalProject) RIO Runner a
inner
    StackYamlLoc
_ -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Cannot use this command with options which override the stack.yaml location"

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

      forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe DockerEntrypoint
globalDockerEntrypoint) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall env.
(HasProcessContext env, HasLogFunc env) =>
Config -> DockerEntrypoint -> RIO env ()
Docker.entrypoint Config
config)
      forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Config
config 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 forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e ->
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Error when running shouldUpgradeCheck: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e)
        case ShouldReexec
shouldReexec of
          ShouldReexec
YesReexec -> 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' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ NixOpts -> Bool
nixEnable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> NixOpts
configNix
  Bool
dockerEnable' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ DockerOpts -> Bool
dockerEnable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> DockerOpts
configDocker
  case (Bool
nixEnable', Bool
dockerEnable') of
    (Bool
True, Bool
True) -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Cannot use both Docker and Nix at the same time"
    (Bool
False, Bool
False) -> RIO Config a
inner

    -- Want to use Nix

    (Bool
True, Bool
False) -> do
      forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). MonadIO m => m Bool
getInContainer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Cannot use Nix from within a Docker container"
      Bool
isReexec <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => SimpleGetter env Bool
reExecL
      if Bool
isReexec
      then RIO Config a
inner
      else forall void. RIO Config void
Nix.runShellAndExit

    -- Want to use Docker

    (Bool
False, Bool
True) -> do
      forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). MonadIO m => m Bool
getInNixShell forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Cannot use Docker from within a Nix shell"
      Bool
inContainer <- forall (m :: * -> *). MonadIO m => m Bool
getInContainer
      if Bool
inContainer
        then do
          Bool
isReexec <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => SimpleGetter env Bool
reExecL
          if Bool
isReexec
            then RIO Config a
inner
            else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
Docker.OnlyOnHostException
        else 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 <-
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ColorWhen
defaultColorWhen forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ ConfigMonoid -> First ColorWhen
configMonoidColorWhen forall a b. (a -> b) -> a -> b
$ GlobalOpts -> ConfigMonoid
globalConfigMonoid GlobalOpts
go
  Bool
useColor <- case ColorWhen
colorWhen of
    ColorWhen
ColorNever -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ColorWhen
ColorAlways -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ColorWhen
ColorAuto -> forall a. a -> Maybe a -> a
fromMaybe Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                          Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stderr
  Int
termWidth <- Int -> Int
clipWidth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a -> a
fromMaybe Int
defaultTerminalWidth
                                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Int)
getTerminalWidth)
                                   forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalOpts -> Maybe Int
globalTermWidth GlobalOpts
go)
  ProcessContext
menv <- forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext
  let update :: StylesUpdate
update = GlobalOpts -> StylesUpdate
globalStylesUpdate GlobalOpts
go
  forall (m :: * -> *) a.
MonadUnliftIO m =>
GlobalOpts -> Bool -> StylesUpdate -> (LogFunc -> m a) -> m a
withNewLogFunc GlobalOpts
go Bool
useColor StylesUpdate
update forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> 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 forall a. Ord a => a -> a -> Bool
< Int
minTerminalWidth = Int
minTerminalWidth
          | Int
w 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configRecommendUpgrade Config
config) forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
    let yesterday :: UTCTime
yesterday = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
24 forall a. Num a => a -> a -> a
* NominalDiffTime
60 forall a. Num a => a -> a -> a
* NominalDiffTime
60) UTCTime
now
    Int
checks <- forall env. HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince UTCTime
yesterday
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
checks forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
      Maybe PackageIdentifierRevision
mversion <- 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 forall a. Ord a => a -> a -> Bool
> Version
stackMinorVersion -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"<<<<<<<<<<<<<<<<<<"
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"You are currently using Stack version " forall a. Semigroup a => a -> a -> a
<>
            forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
stackVersion) forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
", but version " forall a. Semigroup a => a -> a -> a
<>
            forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
version) forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
" is available"
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"You can try to upgrade by running 'stack upgrade'"
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"Tired of seeing this? Add 'recommend-stack-upgrade: false' to " forall a. Semigroup a => a -> a -> a
<>
            forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath (Config -> Path Abs File
configUserConfigPath Config
config))
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
">>>>>>>>>>>>>>>>>>"
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
        Maybe PackageIdentifierRevision
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
now