{-# 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 :: RIO Runner a -> RIO Runner a
withGlobalProject inner :: 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
stackYamlLocL
case StackYamlLoc
oldSYL of
SYLDefault -> (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
stackYamlLocL StackYamlLoc
SYLGlobalProject) RIO Runner a
inner
_ -> String -> RIO Runner a
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString "Cannot use this command with options which override the stack.yaml location"
withDefaultEnvConfig
:: RIO EnvConfig a
-> RIO Config a
withDefaultEnvConfig :: 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
withEnvConfig
:: NeedTargets
-> BuildOptsCLI
-> RIO EnvConfig a
-> RIO Config a
withEnvConfig :: NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig needTargets :: NeedTargets
needTargets boptsCLI :: BuildOptsCLI
boptsCLI inner :: 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 "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
data ShouldReexec = YesReexec | NoReexec
withConfig
:: ShouldReexec
-> RIO Config a
-> RIO Runner a
withConfig :: ShouldReexec -> RIO Config a -> RIO Runner a
withConfig shouldReexec :: ShouldReexec
shouldReexec inner :: RIO Config a
inner =
(Config -> RIO Runner a) -> RIO Runner a
forall env a. HasRunner 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
config -> do
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
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 (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
RIO Config ()
shouldUpgradeCheck RIO Config () -> (SomeException -> RIO Config ()) -> RIO Config ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \e :: SomeException
e ->
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError ("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
YesReexec -> RIO Config a -> RIO Config a
forall a. RIO Config a -> RIO Config a
reexec RIO Config a
inner
NoReexec -> RIO Config a
inner
reexec :: RIO Config a -> RIO Config a
reexec :: RIO Config a -> RIO Config a
reexec inner :: 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
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
(True, True) -> String -> RIO Config a
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString "Cannot use both Docker and Nix at the same time"
(False, False) -> RIO Config a
inner
(True, 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
$ String -> RIO Config ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString "Cannot use Nix from within a Docker container"
Bool
inShell <- RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
getInNixShell
if Bool
inShell
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
reExecL
if Bool
isReexec
then RIO Config a
inner
else String -> RIO Config a
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString "In Nix shell but reExecL is False"
else RIO Config a
forall void. RIO Config void
Nix.runShellAndExit
(False, 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
$ String -> RIO Config ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString "Cannot use Docker from within a Nix shell"
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
reExecL
if Bool
isReexec
then RIO Config a
inner
else StackDockerException -> RIO Config a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
Docker.OnlyOnHostException
else RIO Config a
forall env void. HasConfig env => RIO env void
Docker.runContainerAndExit
withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal go :: GlobalOpts
go inner :: 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 (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
ColorNever -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ColorAlways -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
ColorAuto -> Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> IO (Maybe Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation 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 (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
LogOptions
logOptions0 <- Handle -> Bool -> IO LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
False
let logOptions :: LogOptions
logOptions
= Bool -> LogOptions -> LogOptions
setLogUseColor Bool
useColor
(LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogUseTime (GlobalOpts -> Bool
globalTimeInLog GlobalOpts
go)
(LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ LogLevel -> LogOptions -> LogOptions
setLogMinLevel (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go)
(LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogVerboseFormat (GlobalOpts -> LogLevel
globalLogLevel GlobalOpts
go LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
LevelDebug)
(LogOptions -> LogOptions) -> LogOptions -> LogOptions
forall a b. (a -> b) -> a -> b
$ Bool -> LogOptions -> LogOptions
setLogTerminal (GlobalOpts -> Bool
globalTerminal GlobalOpts
go)
LogOptions
logOptions0
LogOptions -> (LogFunc -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
logOptions ((LogFunc -> IO a) -> IO a) -> (LogFunc -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \logFunc :: LogFunc
logFunc -> Runner -> RIO Runner a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO $WRunner :: GlobalOpts -> Bool -> LogFunc -> Int -> ProcessContext -> Runner
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 w :: 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
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 (-24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* 60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* 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
== 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 "stack" UsePreferredVersions
UsePreferredVersions
case Maybe PackageIdentifierRevision
mversion of
Just (PackageIdentifierRevision _ version :: Version
version _) | Version -> Version
minorVersion Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
stackMinorVersion -> do
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn "<<<<<<<<<<<<<<<<<<"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
"You are currently using Stack version " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
stackVersion) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
", but version " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
version) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
" is available"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn "You can try to upgrade by running 'stack upgrade'"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
"Tired of seeing this? Add 'recommend-stack-upgrade: false' to " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Config -> Path Abs File
configUserConfigPath Config
config))
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn ">>>>>>>>>>>>>>>>>>"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn ""
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn ""
_ -> () -> RIO Config ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
UTCTime -> RIO Config ()
forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
now