{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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)
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"
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
withEnvConfig
:: NeedTargets
-> BuildOptsCLI
-> RIO EnvConfig a
-> 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
data ShouldReexec = YesReexec | NoReexec
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
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
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
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
(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
(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
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
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
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