{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Runners
( withBuildConfig
, withEnvConfig
, withDefaultEnvConfig
, withConfig
, withGlobalProject
, withRunnerGlobal
, ShouldReexec (..)
) where
import RIO.Process ( mkDefaultProcessContext )
import RIO.Time ( addUTCTime, getCurrentTime )
import Stack.Build.Target ( NeedTargets (..) )
import Stack.Config
( getInContainer, getInNixShell, loadConfig, withBuildConfig
, withNewLogFunc
)
import Stack.Constants
( defaultTerminalWidth, maxTerminalWidth, minTerminalWidth )
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.BuildOpts
( BuildOptsCLI, defaultBuildOptsCLI )
import Stack.Types.ColorWhen ( ColorWhen (..) )
import Stack.Types.Config ( Config (..) )
import Stack.Types.ConfigMonoid ( ConfigMonoid (..) )
import Stack.Types.Docker ( dockerEnable )
import Stack.Types.EnvConfig ( EnvConfig )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.Nix ( nixEnable )
import Stack.Types.Runner
( Runner (..), globalOptsL, reExecL, stackYamlLocL )
import Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import Stack.Types.Version
( minorVersion, stackMinorVersion, stackVersion )
import System.Console.ANSI ( hSupportsANSI )
import System.Terminal ( getTerminalWidth )
data RunnersException
= CommandInvalid
| DockerAndNixInvalid
| NixWithinDockerInvalid
| DockerWithinNixInvalid
deriving (Int -> RunnersException -> ShowS
[RunnersException] -> ShowS
RunnersException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunnersException] -> ShowS
$cshowList :: [RunnersException] -> ShowS
show :: RunnersException -> String
$cshow :: RunnersException -> String
showsPrec :: Int -> RunnersException -> ShowS
$cshowsPrec :: Int -> RunnersException -> ShowS
Show, Typeable)
instance Exception RunnersException where
displayException :: RunnersException -> String
displayException RunnersException
CommandInvalid =
String
"Error: [S-7144]\n"
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"
forall a. [a] -> [a] -> [a]
++ String
"Cannot use both Docker and Nix at the same time."
displayException RunnersException
NixWithinDockerInvalid =
String
"Error: [S-8641]\n"
forall a. [a] -> [a] -> [a]
++ String
"Cannot use Nix from within a Docker container."
displayException RunnersException
DockerWithinNixInvalid =
String
"Error: [S-5107]\n"
forall a. [a] -> [a] -> [a]
++ String
"Cannot use Docker from within a Nix shell."
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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
CommandInvalid
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, HasTerm 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 forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Error: [S-7353]\n" forall a. Semigroup a => a -> a -> a
<>
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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
DockerAndNixInvalid
(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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
NixWithinDockerInvalid
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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RunnersException
DockerWithinNixInvalid
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 DockerException
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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
ColorWhen
ColorAlways -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
ColorWhen
ColorAuto -> Handle -> IO Bool
hSupportsANSI 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"You are currently using Stack version"
, forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
stackVersion)
, String -> StyleDoc
flow String
"but version"
, forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
version)
, String -> StyleDoc
flow String
"is available."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
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")
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
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"
, forall a. Pretty a => a -> StyleDoc
pretty (Config -> Path Abs File
configUserConfigPath Config
config) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
Maybe PackageIdentifierRevision
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
now