{-# 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 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
StackYamlLoc
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
StackYamlLoc
_ -> String -> RIO Runner a
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 :: 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 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
data ShouldReexec = YesReexec | NoReexec
withConfig
:: ShouldReexec
-> RIO Config a
-> RIO Runner a
withConfig :: 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 => (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
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` \SomeException
e ->
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (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
reexec :: RIO Config a -> RIO Config a
reexec :: 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
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) -> String -> RIO Config a
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
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 String
"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 String
"In Nix shell but reExecL is False"
else RIO Config a
forall void. RIO Config void
Nix.runShellAndExit
(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
$ String -> RIO Config ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"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 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ColorWhen
ColorAlways -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
ColorWhen
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
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 :: 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 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 (-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
Just (PackageIdentifierRevision PackageName
_ Version
version CabalFileInfo
_) | 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
"<<<<<<<<<<<<<<<<<<"
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
$
Utf8Builder
"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
<>
Utf8Builder
", 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
<>
Utf8Builder
" is available"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"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
$
Utf8Builder
"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
">>>>>>>>>>>>>>>>>>"
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
Maybe PackageIdentifierRevision
_ -> () -> RIO Config ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
UTCTime -> RIO Config ()
forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
now