{-# 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 (upgradeChecksSince, logUpgradeCheck)
import Stack.Types.Config
import Stack.Types.Docker (dockerEnable)
import Stack.Types.Nix (nixEnable)
import Stack.Types.Version (stackMinorVersion, stackVersion, minorVersion)
import System.Console.ANSI (hSupportsANSIWithoutEmulation)
import System.Console.Terminal.Size (size, width)
withGlobalProject :: RIO Runner a -> RIO Runner a
withGlobalProject inner = do
oldSYL <- view stackYamlLocL
case oldSYL of
SYLDefault -> local (set stackYamlLocL SYLGlobalProject) inner
_ -> throwString "Cannot use this command with options which override the stack.yaml location"
withDefaultEnvConfig
:: RIO EnvConfig a
-> RIO Config a
withDefaultEnvConfig = withEnvConfig AllowNoTargets defaultBuildOptsCLI
withBuildConfig :: RIO BuildConfig a -> RIO Config a
withBuildConfig inner = do
bconfig <- loadBuildConfig
runRIO bconfig inner
withEnvConfig
:: NeedTargets
-> BuildOptsCLI
-> RIO EnvConfig a
-> RIO Config a
withEnvConfig needTargets boptsCLI inner =
withBuildConfig $ do
envConfig <- setupEnv needTargets boptsCLI Nothing
logDebug "Starting to execute command inside EnvConfig"
runRIO envConfig inner
data ShouldReexec = YesReexec | NoReexec
withConfig
:: ShouldReexec
-> RIO Config a
-> RIO Runner a
withConfig shouldReexec inner =
loadConfig $ \config -> do
view (globalOptsL.to globalDockerEntrypoint) >>=
traverse_ (Docker.entrypoint config)
runRIO config $ do
shouldUpgradeCheck `catchAny` \e ->
logError ("Error when running shouldUpgradeCheck: " <> displayShow e)
case shouldReexec of
YesReexec -> reexec inner
NoReexec -> inner
reexec :: RIO Config a -> RIO Config a
reexec inner = do
nixEnable' <- asks $ nixEnable . configNix
dockerEnable' <- asks $ dockerEnable . configDocker
case (nixEnable', dockerEnable') of
(True, True) -> throwString "Cannot use both Docker and Nix at the same time"
(False, False) -> inner
(True, False) -> do
whenM getInContainer $ throwString "Cannot use Nix from within a Docker container"
inShell <- getInNixShell
if inShell
then do
isReexec <- view reExecL
if isReexec
then inner
else throwString "In Nix shell but reExecL is False"
else Nix.runShellAndExit
(False, True) -> do
whenM getInNixShell $ throwString "Cannot use Docker from within a Nix shell"
inContainer <- getInContainer
if inContainer
then do
isReexec <- view reExecL
if isReexec
then inner
else throwIO Docker.OnlyOnHostException
else Docker.runContainerAndExit
withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal go inner = do
colorWhen <-
case getFirst $ configMonoidColorWhen $ globalConfigMonoid go of
Nothing -> defaultColorWhen
Just colorWhen -> pure colorWhen
useColor <- case colorWhen of
ColorNever -> return False
ColorAlways -> return True
ColorAuto -> fromMaybe True <$>
hSupportsANSIWithoutEmulation stderr
termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth
<$> fmap (fmap width) size)
pure (globalTermWidth go)
menv <- mkDefaultProcessContext
logOptions0 <- logOptionsHandle stderr False
let logOptions
= setLogUseColor useColor
$ setLogUseTime (globalTimeInLog go)
$ setLogMinLevel (globalLogLevel go)
$ setLogVerboseFormat (globalLogLevel go <= LevelDebug)
$ setLogTerminal (globalTerminal go)
logOptions0
withLogFunc logOptions $ \logFunc -> runRIO Runner
{ runnerGlobalOpts = go
, runnerUseColor = useColor
, runnerLogFunc = logFunc
, runnerTermWidth = termWidth
, runnerProcessContext = menv
} inner
where clipWidth w
| w < minTerminalWidth = minTerminalWidth
| w > maxTerminalWidth = maxTerminalWidth
| otherwise = w
shouldUpgradeCheck :: RIO Config ()
shouldUpgradeCheck = do
config <- ask
when (configRecommendUpgrade config) $ do
now <- getCurrentTime
let yesterday = addUTCTime (-24 * 60 * 60) now
checks <- upgradeChecksSince yesterday
when (checks == 0) $ do
mversion <- getLatestHackageVersion NoRequireHackageIndex "stack" UsePreferredVersions
case mversion of
Just (PackageIdentifierRevision _ version _) | minorVersion version > stackMinorVersion -> do
logWarn "<<<<<<<<<<<<<<<<<<"
logWarn $
"You are currently using Stack version " <>
fromString (versionString stackVersion) <>
", but version " <>
fromString (versionString version) <>
" is available"
logWarn "You can try to upgrade by running 'stack upgrade'"
logWarn $
"Tired of seeing this? Add 'recommend-stack-upgrade: false' to " <>
fromString (toFilePath (configUserConfigPath config))
logWarn ">>>>>>>>>>>>>>>>>>"
logWarn ""
logWarn ""
_ -> pure ()
logUpgradeCheck now