stack-3.11.1: src/Stack/Config.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : Stack.Config
Description : The general Stack configuration.
License : BSD-3-Clause
The general Stack configuration that starts everything off. This should be smart
to fallback if there is no stack.yaml, instead relying on whatever files are
available.
If there is no stack.yaml, and there is a cabal.config, we read in those
constraints, and if there's a cabal.sandbox.config, we read any constraints from
there and also find the package database from there, etc. And if there's
nothing, we should probably default to behaving like cabal, possibly with
spitting out a warning that "you should run `stk init` to make things better".
-}
module Stack.Config
( loadConfig
, loadConfigYaml
, getImplicitGlobalProjectDir
, getSnapshots
, makeConcreteSnapshot
, getRawSnapshot
, checkOwnership
, getInContainer
, getInNixShell
, defaultConfigYaml
, getProjectConfig
, withBuildConfig
, withConfigExtra
, withNewLogFunc
, determineStackRootAndOwnership
) where
import Control.Monad.Extra ( firstJustM )
import Data.Aeson.Types ( Value )
import Data.Aeson.WarningParser
( WithJSONWarnings (..), logJSONWarnings )
import Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import Data.ByteString.Builder ( byteString )
import Data.Char ( isLatin1 )
import Data.Coerce ( coerce )
import qualified Data.Either.Extra as EE
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Data.Yaml.Include as YamlInclude
import qualified Distribution.PackageDescription as PD
import Distribution.System
( Arch (..), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text ( simpleParse )
import Distribution.Version ( simplifyVersionRange )
import qualified Hpack
import GHC.Conc ( getNumProcessors )
import Network.HTTP.StackClient
( httpJSON, parseUrlThrow, getResponseBody )
import Pantry ( loadSnapshot )
import Path
( PathException (..), (</>), parent, parseAbsDir
, parseAbsFile, parseRelDir, stripProperPrefix
)
import Path.Extra ( toFilePathNoTrailingSep )
import Path.Find ( findInParents )
import Path.IO
( XdgDirectory (..), canonicalizePath, doesFileExist
, ensureDir, forgivingAbsence, getAppUserDataDir
, getCurrentDir, getXdgDir, resolveDir, resolveDir'
, resolveFile, resolveFile'
)
import RIO.List ( unzip, intersperse )
import RIO.Process
( HasProcessContext (..), ProcessContext, augmentPathMap
, envVarsL
, mkProcessContext
)
import RIO.Time ( toGregorian )
import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Config.Build ( buildOptsFromMonoid )
import Stack.Config.Docker ( dockerOptsFromMonoid )
import Stack.Config.Nix ( nixOptsFromMonoid )
import Stack.Constants
( defaultGlobalConfigPath, defaultUserConfigPath
, implicitGlobalProjectDir, inContainerEnvVar
, inNixShellEnvVar, osIsWindows, pantryRootEnvVar
, platformVariantEnvVar, relDirBin, relDirStackWork
, relFileReadmeTxt, relFileStorage, relDirPantry
, relDirPrograms, relDirStackProgName, relDirUpperPrograms
, stackDeveloperModeDefault, stackDotYaml, stackProgName
, stackRootEnvVar, stackWorkEnvVar, stackXdgEnvVar
)
import qualified Stack.Constants as Constants
import Stack.Lock ( lockCachedWanted )
import Stack.Prelude
import Stack.SourceMap ( additionalDepPackage, mkProjectPackage )
import Stack.Storage.Project ( initProjectStorage )
import Stack.Storage.User ( initUserStorage )
import Stack.Storage.Util ( handleMigrationException )
import Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) )
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
import Stack.Types.Build.Exception
( BuildException (..), BuildPrettyException (..) )
import Stack.Types.BuildConfig ( BuildConfig (..) )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import Stack.Types.ColorWhen ( ColorWhen (..) )
import Stack.Types.Compiler
( defaultCompilerBindistPath, defaultCompilerRepository
, defaultCompilerTarget
)
import Stack.Types.Config
( Config (..), HasConfig (..), askLatestSnapshotUrl
, configProjectRoot, stackRootL, workDirL
)
import Stack.Types.Config.Exception
( ConfigException (..), ConfigPrettyException (..)
, ParseAbsolutePathException (..)
)
import Stack.Types.ConfigExtra ( ConfigExtra (..) )
import Stack.Types.ConfigMonoid
( ConfigMonoid (..), parseConfigMonoid )
import Stack.Types.Casa ( CasaOptsMonoid (..) )
import Stack.Types.Docker ( DockerOpts (..), DockerOptsMonoid (..) )
import Stack.Types.DumpLogs ( DumpLogs (..) )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.MsysEnvironment
( MsysEnvironment (..), msysEnvArch )
import Stack.Types.Nix ( NixOpts (..) )
import Stack.Types.Platform
( PlatformVariant (..), platformOnlyRelDir )
import Stack.Types.Project ( Project (..) )
import qualified Stack.Types.Project as Project ( Project (..) )
import Stack.Types.ProjectAndConfigMonoid
( ProjectAndConfigMonoid (..), parseProjectAndConfigMonoid )
import Stack.Types.ProjectConfig ( ProjectConfig (..) )
import Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import Stack.Types.Runner
( HasRunner (..), Runner (..), globalOptsL, terminalL )
import Stack.Types.Snapshot ( AbstractSnapshot (..), Snapshots (..) )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), ProjectPackage (..)
, SMWanted (..)
)
import Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
import Stack.Types.Version
( IntersectingVersionRange (..), VersionCheck (..)
, stackVersion, withinRange
)
import System.Console.ANSI ( hNowSupportsANSI, setSGRCode )
import System.Environment ( getEnvironment, lookupEnv )
import System.Info.ShortPathName ( getShortPathName )
import System.PosixCompat.Files ( fileOwner, getFileStatus )
import System.Posix.User ( getEffectiveUserID )
-- | Get the location of the implicit global project directory.
getImplicitGlobalProjectDir :: HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir = view $ stackRootL . to implicitGlobalProjectDir
-- | Download the t'Snapshots' value from stackage.org.
getSnapshots :: HasConfig env => RIO env Snapshots
getSnapshots = do
latestUrlText <- askLatestSnapshotUrl
latestUrl <- parseUrlThrow (T.unpack latestUrlText)
logDebug $ "Downloading snapshot versions file from " <> display latestUrlText
result <- httpJSON latestUrl
logDebug "Done downloading and parsing snapshot versions file"
pure $ getResponseBody result
-- | Turn an 'AbstractSnapshot' into a 'RawSnapshotLocation'.
makeConcreteSnapshot ::
HasConfig env
=> AbstractSnapshot
-> RIO env RawSnapshotLocation
makeConcreteSnapshot (ASSnapshot s) = pure s
makeConcreteSnapshot as = do
s <-
case as of
ASGlobal -> do
fp <- getImplicitGlobalProjectDir <&> (</> stackDotYaml)
iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
ProjectAndConfigMonoid project _ <- liftIO iopc
pure project.snapshot
ASLatestNightly ->
RSLSynonym . Nightly . (.nightly) <$> getSnapshots
ASLatestLTSMajor x -> do
snapshots <- getSnapshots
case IntMap.lookup x snapshots.lts of
Nothing -> throwIO $ NoLTSWithMajorVersion x
Just y -> pure $ RSLSynonym $ LTS x y
ASLatestLTS -> do
snapshots <- getSnapshots
if IntMap.null snapshots.lts
then throwIO NoLTSFound
else let (x, y) = IntMap.findMax snapshots.lts
in pure $ RSLSynonym $ LTS x y
prettyInfoL
[ flow "Selected snapshot:"
, style Current (fromString $ T.unpack $ textDisplay s) <> "."
]
pure s
-- | Get the raw snapshot from the global options.
getRawSnapshot :: HasConfig env => RIO env (Maybe RawSnapshot)
getRawSnapshot = do
mASnapshot <- view $ globalOptsL . to (.snapshot)
forM mASnapshot $ \aSnapshot -> do
concrete <- makeConcreteSnapshot aSnapshot
loc <- completeSnapshotLocation concrete
loadSnapshot loc
-- | Get the latest snapshot available.
getLatestSnapshot :: HasConfig env => RIO env RawSnapshotLocation
getLatestSnapshot = do
snapshots <- getSnapshots
let mlts = uncurry LTS <$>
listToMaybe (reverse (IntMap.toList snapshots.lts))
pure $ RSLSynonym $ fromMaybe (Nightly snapshots.nightly) mlts
-- Interprets ConfigMonoid options.
configFromConfigMonoid ::
(HasRunner env, HasTerm env)
=> Path Abs Dir -- ^ Stack root, e.g. ~/.stack
-> Path Abs File
-- ^ User-specific global configuration file.
-> Maybe AbstractSnapshot
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
stackRoot
userGlobalConfigFile
snapshot
project
configMonoid
inner
= do
-- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK
-- is set, use that. If neither, use the default ".stack-work"
mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar
let mproject =
case project of
PCProject pair -> Just pair
PCGlobalProject -> Nothing
PCNoProject _deps -> Nothing
allowLocals =
case project of
PCProject _ -> True
PCGlobalProject -> True
PCNoProject _ -> False
configWorkDir0 <-
let parseStackWorkEnv x =
catch
(parseRelDir x)
( \e -> case e of
InvalidRelDir _ ->
prettyThrowIO $ StackWorkEnvNotRelativeDir x
_ -> throwIO e
)
in maybe (pure relDirStackWork) (liftIO . parseStackWorkEnv) mstackWorkEnv
let workDir = fromFirst configWorkDir0 configMonoid.workDir
-- The history of the URL below is as follows:
--
-- * Before Stack 1.3.0 it was
-- https://www.stackage.org/download/snapshots.json.
-- * From Stack 1.3.0 to 2.15.3 it was
-- https://s3.amazonaws.com/haddock.stackage.org/snapshots.json. The
-- change was made because S3 was expected to have greater uptime than
-- stackage.org.
-- * In early 2024, the Stackage project was handed over to the Haskell
-- Foundation. Following that handover, the URL below was considered
-- the most reliable source of the file in question.
latestSnapshot = fromFirst
"https://stackage-haddock.haskell.org/snapshots.json"
configMonoid.latestSnapshot
recentSnapshots = fromFirst
"https://www.stackage.org/api/v1/snapshots"
configMonoid.recentSnapshots
clConnectionCount = fromFirst 8 configMonoid.connectionCount
hideTHLoading = fromFirstTrue configMonoid.hideTHLoading
prefixTimestamps = fromFirst False configMonoid.prefixTimestamps
ghcVariant = getFirst configMonoid.ghcVariant
compilerRepository = fromFirst
defaultCompilerRepository
configMonoid.compilerRepository
compilerTarget = fromFirst
defaultCompilerTarget
configMonoid.compilerTarget
compilerBindistPath = fromFirst
defaultCompilerBindistPath
configMonoid.compilerBindistPath
ghcBuild = getFirst configMonoid.ghcBuild
installGHC = fromFirstTrue configMonoid.installGHC
installMsys = fromFirst installGHC configMonoid.installMsys
skipGHCCheck = fromFirstFalse configMonoid.skipGHCCheck
skipMsys = fromFirstFalse configMonoid.skipMsys
extraIncludeDirs = configMonoid.extraIncludeDirs
extraLibDirs = configMonoid.extraLibDirs
customPreprocessorExts = configMonoid.customPreprocessorExts
overrideGccPath = getFirst configMonoid.overrideGccPath
-- Only place in the codebase where platform is hard-coded. In theory in
-- the future, allow it to be configured.
(Platform defArch defOS) = buildPlatform
arch = fromMaybe defArch
$ getFirst configMonoid.arch >>= Distribution.Text.simpleParse
os = defOS
platform = Platform arch os
requireStackVersion = simplifyVersionRange
configMonoid.requireStackVersion.intersectingVersionRange
compilerCheck = fromFirst MatchMinor configMonoid.compilerCheck
mMsysEnv = case platform of
Platform X86_64 Windows ->
-- Default CLANG64 on 64-bit Windows:
Just $ fromFirst CLANG64 configMonoid.msysEnvironment
Platform _ Windows ->
-- No default on unsupported 32-bit Windows:
getFirst configMonoid.msysEnvironment
_ -> Nothing
msysEnvironment <- case mMsysEnv of
Nothing -> pure Nothing
Just msysEnv
| msysEnvArch msysEnv == arch -> pure $ Just msysEnv
| otherwise -> prettyThrowM $ BadMsysEnvironment msysEnv arch
platformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
let build = buildOptsFromMonoid configMonoid.buildOpts
docker <-
dockerOptsFromMonoid (fmap fst mproject) snapshot configMonoid.dockerOpts
nix <- nixOptsFromMonoid configMonoid.nixOpts os
systemGHC <-
case (getFirst configMonoid.systemGHC, nix.enable) of
(Just False, True) ->
throwM NixRequiresSystemGhc
_ ->
pure
(fromFirst
(docker.enable || nix.enable)
configMonoid.systemGHC)
when (isJust ghcVariant && systemGHC) $
throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
rawEnv <- liftIO getEnvironment
pathsEnv <- either throwM pure
$ augmentPathMap (map toFilePath configMonoid.extraPath)
(Map.fromList (map (T.pack *** T.pack) rawEnv))
origEnv <- mkProcessContext pathsEnv
let processContextSettings _ = pure origEnv
localProgramsBase <- case getFirst configMonoid.localProgramsBase of
Nothing -> getDefaultLocalProgramsBase stackRoot platform origEnv
Just path -> pure path
let localProgramsFilePath = toFilePath localProgramsBase
spaceInLocalProgramsPath = ' ' `elem` localProgramsFilePath
nonLatin1InLocalProgramsPath = not $ all isLatin1 localProgramsFilePath
problematicLocalProgramsPath =
nonLatin1InLocalProgramsPath
|| (osIsWindows && spaceInLocalProgramsPath)
when problematicLocalProgramsPath $ do
let msgSpace =
[ flow "It contains a space character. This will prevent building \
\with GHC 9.4.1 or later."
| osIsWindows && spaceInLocalProgramsPath
]
msgNoShort <- if osIsWindows && spaceInLocalProgramsPath
then do
ensureDir localProgramsBase
-- getShortPathName returns the long path name when a short name does not
-- exist.
shortLocalProgramsFilePath <-
liftIO $ getShortPathName localProgramsFilePath
pure [ flow "It also has no alternative short ('8 dot 3') name. This \
\will cause problems with packages that use the GNU \
\project's 'configure' shell script."
| ' ' `elem` shortLocalProgramsFilePath
]
else pure []
let msgNonLatin1 = if nonLatin1InLocalProgramsPath
then
[ flow "It contains at least one non-ISO/IEC 8859-1 (Latin-1) \
\character (Unicode code point > 255). This will cause \
\problems with packages that build using the"
, style Shell "hsc2hs"
, flow "tool with its default template"
, style Shell "template-hsc.h" <> "."
]
else []
prettyWarn $
"[S-8432]"
<> line
<> fillSep
( [ flow "Stack's 'programs' path is"
, style File (fromString localProgramsFilePath) <> "."
]
<> msgSpace
<> msgNoShort
<> msgNonLatin1
)
<> blankLine
<> fillSep
[ flow "To avoid such problems, use the"
, style Shell "local-programs-path"
, flow "non-project specific configuration option to specify an \
\alternative path without those characteristics."
]
<> line
platformOnlyDir <-
runReaderT platformOnlyRelDir (platform, platformVariant)
let localPrograms = localProgramsBase </> platformOnlyDir
localBin <-
case getFirst configMonoid.localBinPath of
Nothing -> do
localDir <- getAppUserDataDir "local"
pure $ localDir </> relDirBin
Just userPath ->
(case mproject of
-- Not in a project
Nothing -> resolveDir' userPath
-- Resolves to the project dir and appends the user path if it is
-- relative
Just (_, configYaml) -> resolveDir (parent configYaml) userPath)
-- TODO: Either catch specific exceptions or add a
-- parseRelAsAbsDirMaybe utility and use it along with
-- resolveDirMaybe.
`catchAny`
const (throwIO (NoSuchDirectory userPath))
fileWatchHook <-
case getFirst configMonoid.fileWatchHook of
Nothing -> pure Nothing
Just userPath ->
( case mproject of
-- Not in a project
Nothing -> Just <$> resolveFile' userPath
-- Resolves to the project dir and appends the user path if it is
-- relative
Just (_, configYaml) ->
Just <$> resolveFile (parent configYaml) userPath
)
-- TODO: Either catch specific exceptions or add a
-- parseRelAsAbsFileMaybe utility and use it along with
-- resolveFileMaybe.
`catchAny`
const (throwIO (NoSuchFile userPath))
jobs <-
case getFirst configMonoid.jobs of
Nothing -> liftIO getNumProcessors
Just i -> pure i
let concurrentTests =
fromFirst True configMonoid.concurrentTests
templateParams = configMonoid.templateParameters
scmInit = getFirst configMonoid.scmInit
cabalConfigOpts = coerce configMonoid.cabalConfigOpts
ghcOptionsByName = coerce configMonoid.ghcOptionsByName
ghcOptionsByCat = coerce configMonoid.ghcOptionsByCat
setupInfoLocations = configMonoid.setupInfoLocations
setupInfoInline = configMonoid.setupInfoInline
pvpBounds =
fromFirst (PvpBounds PvpBoundsNone False) configMonoid.pvpBounds
modifyCodePage = fromFirstTrue configMonoid.modifyCodePage
rebuildGhcOptions =
fromFirstFalse configMonoid.rebuildGhcOptions
applyGhcOptions =
fromFirst AGOLocals configMonoid.applyGhcOptions
applyProgOptions =
fromFirst APOLocals configMonoid.applyProgOptions
allowNewer = configMonoid.allowNewer
allowNewerDeps = coerce configMonoid.allowNewerDeps
defaultInitSnapshot <- do
root <- getCurrentDir
let resolve = (First <$>) . traverse (resolvePaths (Just root)) . getFirst
resolve configMonoid.defaultInitSnapshot
let defaultTemplate = getFirst configMonoid.defaultTemplate
dumpLogs = fromFirst DumpWarningLogs configMonoid.dumpLogs
saveHackageCreds = configMonoid.saveHackageCreds
hackageBaseUrl =
fromFirst Constants.hackageBaseUrl configMonoid.hackageBaseUrl
hideSourcePaths = fromFirstTrue configMonoid.hideSourcePaths
recommendStackUpgrade = fromFirstTrue configMonoid.recommendStackUpgrade
notifyIfNixOnPath = fromFirstTrue configMonoid.notifyIfNixOnPath
notifyIfGhcUntested = fromFirstTrue configMonoid.notifyIfGhcUntested
notifyIfCabalUntested = fromFirstTrue configMonoid.notifyIfCabalUntested
notifyIfArchUnknown = fromFirstTrue configMonoid.notifyIfArchUnknown
notifyIfNoRunTests = fromFirstTrue configMonoid.notifyIfNoRunTests
notifyIfNoRunBenchmarks =
fromFirstTrue configMonoid.notifyIfNoRunBenchmarks
notifyIfBaseNotBoot =
fromFirstTrue configMonoid.notifyIfBaseNotBoot
noRunCompile = fromFirstFalse configMonoid.noRunCompile
allowDifferentUser <-
case getFirst configMonoid.allowDifferentUser of
Just True -> pure True
_ -> getInContainer
configRunner' <- view runnerL
useAnsi <- liftIO $ hNowSupportsANSI stderr
let stylesUpdate' = (configRunner' ^. stylesUpdateL) <>
configMonoid.styles
useColor' = configRunner'.useColor
mUseColor =
getFirst configMonoid.colorWhen <&> \case
ColorNever -> False
ColorAlways -> True
ColorAuto -> useAnsi
useColor'' = fromMaybe useColor' mUseColor
configRunner'' = configRunner'
& processContextL .~ origEnv
& stylesUpdateL .~ stylesUpdate'
& useColorL .~ useColor''
go = configRunner'.globalOpts
pic = fromFirst defaultPackageIndexConfig configMonoid.packageIndex
pantryRoot <- liftIO (lookupEnv pantryRootEnvVar) >>= \case
Just dir ->
case parseAbsDir dir of
Nothing -> throwIO $ ParseAbsolutePathException pantryRootEnvVar dir
Just x -> pure x
Nothing -> pure $ stackRoot </> relDirPantry
let snapLoc =
case getFirst configMonoid.snapshotLocation of
Nothing -> defaultSnapshotLocation
Just addr ->
customSnapshotLocation
where
customSnapshotLocation (LTS x y) =
mkRSLUrl $ addr'
<> "/lts/" <> display x
<> "/" <> display y <> ".yaml"
customSnapshotLocation (Nightly date) =
let (year, month, day) = toGregorian date
in mkRSLUrl $ addr'
<> "/nightly/"
<> display year
<> "/" <> display month
<> "/" <> display day <> ".yaml"
mkRSLUrl builder = RSLUrl (utf8BuilderToText builder) Nothing
addr' = display $ T.dropWhileEnd (=='/') addr
globalHintsLoc <- case getFirst configMonoid.globalHintsLocation of
Nothing -> pure defaultGlobalHintsLocation
Just unresolverGlobalHintsLoc -> do
resolvedGlobalHintsLocation <-
resolvePaths (Just stackRoot) unresolverGlobalHintsLoc
pure $ const resolvedGlobalHintsLocation
let stackDeveloperMode = fromFirst
stackDeveloperModeDefault
configMonoid.stackDeveloperMode
hpackForce = if fromFirstFalse configMonoid.hpackForce
then Hpack.Force
else Hpack.NoForce
casa =
if fromFirstTrue configMonoid.casaOpts.enable
then
let casaRepoPrefix = fromFirst
(fromFirst defaultCasaRepoPrefix configMonoid.casaRepoPrefix)
configMonoid.casaOpts.repoPrefix
casaMaxKeysPerRequest = fromFirst
defaultCasaMaxPerRequest
configMonoid.casaOpts.maxKeysPerRequest
in Just (casaRepoPrefix, casaMaxKeysPerRequest)
else Nothing
withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
let runner = configRunner'' & logFuncL .~ logFunc
withLocalLogFunc logFunc $ handleMigrationException $ do
logDebug $ case casa of
Nothing -> "Use of Casa server disabled."
Just (repoPrefix, maxKeys) ->
"Use of Casa server enabled: ("
<> fromString (show repoPrefix)
<> ", "
<> fromString (show maxKeys)
<> ")."
withPantryConfig'
pantryRoot
pic
(maybe HpackBundled HpackCommand $ getFirst configMonoid.overrideHpack)
hpackForce
clConnectionCount
casa
snapLoc
globalHintsLoc
(\pantryConfig -> initUserStorage
(stackRoot </> relFileStorage)
( \userStorage -> inner Config
{ workDir
, userGlobalConfigFile
, build
, docker
, nix
, processContextSettings
, localProgramsBase
, localPrograms
, hideTHLoading
, prefixTimestamps
, platform
, platformVariant
, ghcVariant
, ghcBuild
, latestSnapshot
, recentSnapshots
, systemGHC
, installGHC
, installMsys
, skipGHCCheck
, skipMsys
, msysEnvironment
, compilerCheck
, compilerRepository
, compilerTarget
, compilerBindistPath
, localBin
, fileWatchHook
, requireStackVersion
, jobs
, overrideGccPath
, extraIncludeDirs
, extraLibDirs
, customPreprocessorExts
, concurrentTests
, templateParams
, scmInit
, ghcOptionsByName
, ghcOptionsByCat
, cabalConfigOpts
, setupInfoLocations
, setupInfoInline
, pvpBounds
, modifyCodePage
, rebuildGhcOptions
, applyGhcOptions
, applyProgOptions
, allowNewer
, allowNewerDeps
, defaultInitSnapshot
, defaultTemplate
, allowDifferentUser
, dumpLogs
, project
, allowLocals
, saveHackageCreds
, hackageBaseUrl
, runner
, pantryConfig
, stackRoot
, snapshot
, userStorage
, hideSourcePaths
, recommendStackUpgrade
, notifyIfNixOnPath
, notifyIfGhcUntested
, notifyIfCabalUntested
, notifyIfArchUnknown
, notifyIfNoRunTests
, notifyIfNoRunBenchmarks
, notifyIfBaseNotBoot
, noRunCompile
, stackDeveloperMode
, casa
}
)
)
-- | Runs the provided action with the given 'LogFunc' in the environment
withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
withLocalLogFunc logFunc = local (set logFuncL logFunc)
-- | Runs the provided action with a new 'LogFunc', given a t'StylesUpdate'.
withNewLogFunc ::
MonadUnliftIO m
=> GlobalOpts
-> Bool -- ^ Use color
-> StylesUpdate
-> (LogFunc -> m a)
-> m a
withNewLogFunc go useColor (StylesUpdate update) inner = do
logOptions0 <- logOptionsHandle stderr False
let logOptions
= setLogUseColor useColor
$ setLogLevelColors logLevelColors
$ setLogSecondaryColor secondaryColor
$ setLogAccentColors (const highlightColor)
$ setLogUseTime go.timeInLog
$ setLogMinLevel go.logLevel
$ setLogVerboseFormat (go.logLevel <= LevelDebug)
$ setLogTerminal go.terminal
logOptions0
withLogFunc logOptions inner
where
styles = defaultStyles // update
logLevelColors :: LogLevel -> Utf8Builder
logLevelColors level =
fromString $ setSGRCode $ snd $ styles ! logLevelToStyle level
secondaryColor = fromString $ setSGRCode $ snd $ styles ! Secondary
highlightColor = fromString $ setSGRCode $ snd $ styles ! Highlight
-- | Get the default location of the local programs directory.
getDefaultLocalProgramsBase ::
MonadThrow m
=> Path Abs Dir
-> Platform
-> ProcessContext
-> m (Path Abs Dir)
getDefaultLocalProgramsBase configStackRoot configPlatform override =
case configPlatform of
-- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is
-- used instead of a subdirectory of STACK_ROOT. Unifying the defaults would
-- mean that Windows users would manually have to move data from the old
-- location to the new one, which is undesirable.
Platform _ Windows -> do
let envVars = view envVarsL override
case T.unpack <$> Map.lookup "LOCALAPPDATA" envVars of
Just t -> case parseAbsDir t of
Nothing ->
throwM $ ParseAbsolutePathException "LOCALAPPDATA" t
Just lad ->
pure $ lad </> relDirUpperPrograms </> relDirStackProgName
Nothing -> pure defaultBase
_ -> pure defaultBase
where
defaultBase = configStackRoot </> relDirPrograms
-- | Load the configuration, using current directory, environment variables,
-- and defaults as necessary.
loadConfig ::
(HasRunner env, HasTerm env)
=> (Config -> RIO env a)
-> RIO env a
loadConfig inner = do
mstackYaml <- view $ globalOptsL . to (.stackYaml)
mproject <- loadProjectConfig mstackYaml
mASnapshot <- view $ globalOptsL . to (.snapshot)
configArgs <- view $ globalOptsL . to (.configMonoid)
(configRoot, stackRoot, userOwnsStackRoot) <-
determineStackRootAndOwnership configArgs
let (mproject', addConfigMonoid) =
case mproject of
PCProject (proj, fp, cm) -> (PCProject (proj, fp), (cm:))
PCGlobalProject -> (PCGlobalProject, id)
PCNoProject deps -> (PCNoProject deps, id)
userConfigPath <- getDefaultUserConfigPath configRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>=
mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)
let extraConfigs =
-- non-project config files' existence of a docker section should never
-- default docker to enabled, so make it look like they didn't exist
map
(\c -> c {dockerOpts = c.dockerOpts { defaultEnable = Any False }})
extraConfigs0
let withConfig =
configFromConfigMonoid
stackRoot
userConfigPath
mASnapshot
mproject'
(mconcat $ configArgs : addConfigMonoid extraConfigs)
withConfig $ \config -> do
let Platform arch _ = config.platform
case arch of
OtherArch unknownArch
| config.notifyIfArchUnknown ->
prettyWarnL
[ flow "Unknown value for architecture setting:"
, style Shell (fromString unknownArch) <> "."
, flow "To mute this message in future, set"
, style Shell (flow "notify-if-arch-unknown: false")
, flow "in Stack's configuration."
]
_ -> pure ()
unless (stackVersion `withinRange` config.requireStackVersion)
(throwM (BadStackVersionException config.requireStackVersion))
unless config.allowDifferentUser $ do
unless userOwnsStackRoot $
throwM (UserDoesn'tOwnDirectory stackRoot)
forM_ (configProjectRoot config) $ \dir ->
checkOwnership (dir </> config.workDir)
inner config
-- | Load the build configuration, adds build-specific values to config loaded
-- by @loadConfig@. values.
withBuildConfig :: RIO BuildConfig a -> RIO Config a
withBuildConfig inner = do
withConfigExtra True $ \configExtra -> do
-- The mcompiler is provided on the command line.
mcompiler <- view $ globalOptsL . to (.compiler)
let config = configExtra.config
project' = configExtra.project
configFile = configExtra.configFile
project :: Project
project = project'
{ Project.compiler = mcompiler <|> project'.compiler
, Project.snapshot = fromMaybe project'.snapshot configExtra.mSnapshot
}
-- We are indifferent as to whether the configuration file is a
-- user-specific global or a project-level one.
eitherConfigFile = EE.fromEither configFile
extraPackageDBs <- mapM resolveDir' project.extraPackageDBs
smWanted <- lockCachedWanted eitherConfigFile project.snapshot $
fillProjectWanted eitherConfigFile config project
-- Unfortunately redoes getWorkDir, since we don't have a BuildConfig yet
workDir <- view workDirL
let projectStorageFile =
parent eitherConfigFile </> workDir </> relFileStorage
initProjectStorage projectStorageFile $ \projectStorage -> do
let bc = BuildConfig
{ config
, smWanted
, extraPackageDBs
, configFile
, curator = project.curator
, projectStorage
}
runRIO bc inner
-- | Adds certain build-specific values to the configuration loaded by
-- @loadConfig@ values.
withConfigExtra ::
forall a env. (HasConfig env, HasTerm env)
=> Bool
-- ^ Report user message in the project-level configuration file, if
-- a user message is present?
-> (ConfigExtra -> RIO env a)
-> RIO env a
withConfigExtra reportUserMessage inner = do
config <- view configL
-- If provided, turn the AbstractSnapshot from the command line into a
-- snapshot that can be used.
-- The snapshot is provided on the command line. In order to properly deal
-- with an AbstractSnapshot, we need a base directory (to deal with custom
-- snapshot relative paths). We consider the current working directory to be
-- the correct base. We calculate the mSnapshot first.
mSnapshot <- forM config.snapshot $ \aSnapshot -> do
logDebug $
"Using snapshot: "
<> display aSnapshot
<> " specified on command line"
makeConcreteSnapshot aSnapshot
(project, configFile) <- case config.project of
PCProject (project, fp) -> do
when reportUserMessage $
forM_ project.userMsg prettyUserMessage
pure (project, Right fp)
PCNoProject extraDeps -> do
project <-
case mSnapshot of
Nothing -> throwIO NoSnapshotWhenUsingNoProject
Just _ -> getEmptyProject mSnapshot extraDeps
pure (project, Left config.userGlobalConfigFile)
PCGlobalProject -> do
logDebug "Run from outside a project, using implicit global project config"
destDir <- getImplicitGlobalProjectDir
let dest :: Path Abs File
dest = destDir </> stackDotYaml
dest' :: FilePath
dest' = toFilePath dest
ensureDir destDir
exists <- doesFileExist dest
if exists
then do
iopc <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest
ProjectAndConfigMonoid project _ <- liftIO iopc
when (view terminalL config) $
case config.snapshot of
Nothing ->
logDebug $
"Using snapshot: "
<> display project.snapshot
<> " from implicit global project's config file: "
<> fromString dest'
Just _ -> pure ()
pure (project, Right dest)
else do
prettyInfoL
[ flow "Writing the configuration file for the implicit \
\global project to:"
, pretty dest <> "."
, flow "Note: You can change the snapshot via the"
, style Shell "snapshot"
, flow "key there."
]
project <- getEmptyProject mSnapshot []
liftIO $ do
writeBinaryFileAtomic dest $ byteString $ S.concat
[ "# This is the implicit global project's configuration file, which is only used\n"
, "# when 'stack' is run outside of a real project. Settings here do _not_ act as\n"
, "# defaults for all projects. To change Stack's default settings, edit\n"
, "# '", encodeUtf8 (T.pack $ toFilePath config.userGlobalConfigFile), "' instead.\n"
, "#\n"
, "# For more information about Stack's configuration, see\n"
, "# http://docs.haskellstack.org/en/stable/configure/yaml/\n"
, "#\n"
, Yaml.encode project
]
writeBinaryFileAtomic (parent dest </> relFileReadmeTxt) $ mconcat
[ "This is the implicit global project, which is used only when 'stack' is run\n"
, "outside of a real project.\n"
]
pure (project, Right dest)
inner $ ConfigExtra
{ config
, mSnapshot
, project
, configFile
}
where
getEmptyProject ::
Maybe RawSnapshotLocation
-> [RawPackageLocationImmutable]
-> RIO env Project
getEmptyProject mSnapshot extraDeps = do
snapshot <- case mSnapshot of
Just snapshot -> do
prettyInfoL
[ flow "Using the snapshot"
, style Current (fromString $ T.unpack $ textDisplay snapshot)
, flow "specified on the command line."
]
pure snapshot
Nothing -> do
r'' <- getLatestSnapshot
prettyInfoL
[ flow "Using the latest snapshot"
, style Current (fromString $ T.unpack $ textDisplay r'') <> "."
]
pure r''
pure Project
{ userMsg = Nothing
, packages = []
, extraDeps = map RPLImmutable extraDeps
, flagsByPkg = mempty
, snapshot
, compiler = Nothing
, extraPackageDBs = []
, curator = Nothing
, dropPackages = mempty
}
prettyUserMessage :: String -> RIO env ()
prettyUserMessage userMsg = do
let userMsgs = map flow $ splitAtLineEnds userMsg
warningDoc = mconcat $ intersperse blankLine userMsgs
prettyWarn warningDoc
where
splitAtLineEnds = reverse . map reverse . go []
where
go :: [String] -> String -> [String]
go ss [] = ss
go ss s = case go' [] s of
([], rest) -> go ss rest
(s', rest) -> go (s' : ss) rest
go' :: String -> String -> (String, String)
go' s [] = (s, [])
go' s [c] = (c:s, [])
go' s "\n\n" = (s, [])
go' s [c1, c2] = (c2:c1:s, [])
go' s ('\n':'\n':rest) = (s, stripLineEnds rest)
go' s ('\n':'\r':'\n':rest) = (s, stripLineEnds rest)
go' s ('\r':'\n':'\n':rest) = (s, stripLineEnds rest)
go' s ('\r':'\n':'\r':'\n':rest) = (s, stripLineEnds rest)
go' s (c:rest) = go' (c:s) rest
stripLineEnds :: String -> String
stripLineEnds ('\n':rest) = stripLineEnds rest
stripLineEnds ('\r':'\n':rest) = stripLineEnds rest
stripLineEnds rest = rest
fillProjectWanted ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> Path Abs File
-- ^ Location of the configuration file, which may be either a
-- user-specific global or a project-level one.
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted configFile config project locCache snapCompiler snapPackages = do
let bopts = config.build
packages0 <- for project.packages $ \fp@(RelFilePath t) -> do
abs' <- resolveDir (parent configFile) (T.unpack t)
let resolved = ResolvedPath fp abs'
pp <- mkProjectPackage YesPrintWarnings resolved bopts.buildHaddocks
pure (pp.projectCommon.name, pp)
-- prefetch git repos to avoid cloning per subdirectory
-- see https://github.com/commercialhaskell/stack/issues/5411
let gitRepos = mapMaybe
( \case
(RPLImmutable (RPLIRepo repo rpm)) -> Just (repo, rpm)
_ -> Nothing
)
project.extraDeps
logDebug ("Prefetching git repos: " <> display (T.pack (show gitRepos)))
fetchReposRaw gitRepos
(deps0, mcompleted) <- fmap unzip . forM project.extraDeps $ \rpl -> do
(pl, mCompleted) <- case rpl of
RPLImmutable rpli -> do
(compl, mcompl) <-
case Map.lookup rpli locCache of
Just compl -> pure (compl, Just compl)
Nothing -> do
cpl <- completePackageLocation rpli
if cplHasCabalFile cpl
then pure (cplComplete cpl, Just $ cplComplete cpl)
else do
warnMissingCabalFile rpli
pure (cplComplete cpl, Nothing)
pure (PLImmutable compl, CompletedPLI rpli <$> mcompl)
RPLMutable p ->
pure (PLMutable p, Nothing)
dp <- additionalDepPackage (shouldHaddockDeps bopts) pl
pure ((dp.depCommon.name, dp), mCompleted)
checkDuplicateNames $
map (second (PLMutable . (.resolvedDir))) packages0 ++
map (second (.location)) deps0
let packages1 = Map.fromList packages0
snPackages = snapPackages
`Map.difference` packages1
`Map.difference` Map.fromList deps0
`Map.withoutKeys` project.dropPackages
snDeps <- for snPackages $ \getDep -> getDep (shouldHaddockDeps bopts)
let deps1 = Map.fromList deps0 `Map.union` snDeps
let mergeApply m1 m2 f =
MS.merge MS.preserveMissing MS.dropMissing (MS.zipWithMatched f) m1 m2
pFlags = project.flagsByPkg
packages2 = mergeApply packages1 pFlags $ \_ p flags ->
p { projectCommon = p.projectCommon { flags = flags } }
deps2 = mergeApply deps1 pFlags $ \_ d flags ->
d { depCommon = d.depCommon { flags = flags } }
checkFlagsUsedThrowing pFlags packages1 deps1
let pkgGhcOptions = config.ghcOptionsByName
deps = mergeApply deps2 pkgGhcOptions $ \_ d options ->
d { depCommon = d.depCommon { ghcOptions = options } }
packages = mergeApply packages2 pkgGhcOptions $ \_ p options ->
p { projectCommon = p.projectCommon { ghcOptions = options } }
unusedPkgGhcOptions =
pkgGhcOptions `Map.restrictKeys` Map.keysSet packages2
`Map.restrictKeys` Map.keysSet deps2
unless (Map.null unusedPkgGhcOptions) $
throwM $ InvalidGhcOptionsSpecification (Map.keys unusedPkgGhcOptions)
let wanted = SMWanted
{ compiler = fromMaybe snapCompiler project.compiler
, project = packages
, deps = deps
, snapshotLocation = project.snapshot
}
pure (wanted, catMaybes mcompleted)
-- | Check if a package is a project package or a dependency and, if it is,
-- if all the specified flags are defined in the package's Cabal file.
checkFlagsUsedThrowing ::
forall m. (MonadIO m, MonadThrow m)
=> Map PackageName (Map FlagName Bool)
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing packageFlags projectPackages deps = do
unusedFlags <- forMaybeM (Map.toList packageFlags) getUnusedPackageFlags
unless (null unusedFlags) $
prettyThrowM $ InvalidFlagSpecification unusedFlags
where
getUnusedPackageFlags ::
(PackageName, Map FlagName Bool)
-> m (Maybe UnusedFlags)
getUnusedPackageFlags (name, userFlags) = case maybeCommon of
-- Package is not available as project or dependency
Nothing -> pure $ Just $ UFNoPackage FSStackYaml name
-- Package exists, let's check if the flags are defined
Just common -> do
gpd <- liftIO common.gpd
let pname = pkgName $ PD.package $ PD.packageDescription gpd
pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
pure $ if Set.null unused
-- All flags are defined, nothing to do
then Nothing
-- Error about the undefined flags
else Just $ UFFlagsNotDefined FSStackYaml pname pkgFlags unused
where
maybeCommon = fmap (.projectCommon) (Map.lookup name projectPackages)
<|> fmap (.depCommon) (Map.lookup name deps)
-- | Check if there are any duplicate package names and, if so, throw an
-- exception.
checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames locals =
case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second pure) locals of
[] -> pure ()
x -> prettyThrowM $ DuplicateLocalPackageNames x
where
hasMultiples (_, _:_:_) = True
hasMultiples _ = False
-- | Get the Stack root, e.g. @~/.stack@, and determine whether the user owns it.
--
-- On Windows, the second value is always 'True'.
determineStackRootAndOwnership ::
MonadIO m
=> ConfigMonoid
-- ^ Parsed command-line arguments
-> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership clArgs = liftIO $ do
(configRoot, stackRoot) <-
case getFirst clArgs.stackRoot of
Just x -> pure (x, x)
Nothing ->
lookupEnv stackRootEnvVar >>= \case
Nothing -> do
wantXdg <- fromMaybe "" <$> lookupEnv stackXdgEnvVar
if not (null wantXdg)
then do
xdgRelDir <- parseRelDir stackProgName
(,)
<$> getXdgDir XdgConfig (Just xdgRelDir)
<*> getXdgDir XdgData (Just xdgRelDir)
else do
oldStyleRoot <- getAppUserDataDir stackProgName
pure (oldStyleRoot, oldStyleRoot)
Just x -> case parseAbsDir x of
Nothing ->
throwIO $ ParseAbsolutePathException stackRootEnvVar x
Just parsed -> pure (parsed, parsed)
(existingStackRootOrParentDir, userOwnsIt) <-
findInParents getDirAndOwnership stackRoot >>= \case
Just x -> pure x
Nothing -> throwIO (BadStackRoot stackRoot)
when (existingStackRootOrParentDir /= stackRoot) $
if userOwnsIt
then ensureDir stackRoot
else throwIO $
Won'tCreateStackRootInDirectoryOwnedByDifferentUser
stackRoot
existingStackRootOrParentDir
configRoot' <- canonicalizePath configRoot
stackRoot' <- canonicalizePath stackRoot
pure (configRoot', stackRoot', userOwnsIt)
-- | @'checkOwnership' dir@ throws 'UserDoesn'tOwnDirectory' if @dir@ isn't
-- owned by the current user.
--
-- If @dir@ doesn't exist, its parent directory is checked instead.
-- If the parent directory doesn't exist either,
-- @'NoSuchDirectory' ('parent' dir)@ is thrown.
checkOwnership :: MonadIO m => Path Abs Dir -> m ()
checkOwnership dir =
firstJustM getDirAndOwnership [dir, parent dir] >>= \case
Just (_, True) -> pure ()
Just (dir', False) -> throwIO (UserDoesn'tOwnDirectory dir')
Nothing ->
throwIO . NoSuchDirectory $ (toFilePathNoTrailingSep . parent) dir
-- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@
-- exists and the current user owns it in the sense of 'isOwnedByUser'.
getDirAndOwnership ::
MonadIO m
=> Path Abs Dir
-> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership dir = liftIO $ forgivingAbsence $ do
ownership <- isOwnedByUser dir
pure (dir, ownership)
-- | Check whether the current user (determined with
-- 'System.Posix.User.getEffectiveUserId') is the owner for the given path.
--
-- Will always pure 'True' on Windows.
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser path = liftIO $
if osIsWindows
then pure True
else do
fileStatus <- getFileStatus (toFilePath path)
user <- getEffectiveUserID
pure (user == fileOwner fileStatus)
-- | 'True' if we are currently running inside a Docker container.
getInContainer :: MonadIO m => m Bool
getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
-- | 'True' if we are currently running inside a Nix.
getInNixShell :: MonadIO m => m Bool
getInNixShell = liftIO (isJust <$> lookupEnv inNixShellEnvVar)
-- | Determine the extra config file locations which exist.
--
-- Returns most local first
getExtraConfigs ::
HasTerm env
=> Path Abs File -- ^ use config path
-> RIO env [Path Abs File]
getExtraConfigs userConfigPath = liftIO $ do
env <- getEnvironment
mstackConfig <-
maybe (pure Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_CONFIG" env
mstackGlobalConfig <-
maybe (pure Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_GLOBAL_CONFIG" env
filterM doesFileExist
$ fromMaybe userConfigPath mstackConfig
: maybe [] pure (mstackGlobalConfig <|> defaultGlobalConfigPath)
-- | Load and parse YAML from the given config file. Throws
-- 'ParseConfigFileException' when there's a decoding error.
loadConfigYaml ::
HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadConfigYaml parser path = loadYaml parser path >>= \case
Left err -> prettyThrowM (ParseConfigFileException path err)
Right res -> pure res
-- | Load and parse YAML from the given file.
loadYaml ::
HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a))
-> Path Abs File
-> RIO env (Either Yaml.ParseException a)
loadYaml parser path =
liftIO (YamlInclude.decodeFileEither (toFilePath path)) >>= \case
Left err -> pure (Left err)
Right val ->
case Yaml.parseEither parser val of
Left err -> pure (Left (Yaml.AesonException err))
Right (WithJSONWarnings res warnings) -> do
logJSONWarnings (toFilePath path) warnings
pure (Right res)
-- | Get the location of the project config file, if it exists.
getProjectConfig ::
HasTerm env
=> StackYamlLoc
-- ^ Override stack.yaml
-> RIO env (ProjectConfig (Path Abs File))
getProjectConfig (SYLOverride stackYaml) = pure $ PCProject stackYaml
getProjectConfig SYLGlobalProject = pure PCGlobalProject
getProjectConfig SYLDefault = do
env <- liftIO getEnvironment
case lookup "STACK_YAML" env of
Just fp -> do
prettyInfoS
"Getting the project-level configuration file from the \
\STACK_YAML environment variable."
PCProject <$> resolveFile' fp
Nothing -> do
currDir <- getCurrentDir
maybe PCGlobalProject PCProject <$> findInParents getStackDotYaml currDir
where
getStackDotYaml dir = do
let fp = dir </> stackDotYaml
fp' = toFilePath fp
logDebug $ "Checking for project config at: " <> fromString fp'
exists <- doesFileExist fp
if exists
then pure $ Just fp
else pure Nothing
getProjectConfig (SYLNoProject extraDeps) = pure $ PCNoProject extraDeps
-- | Find the project config file location, respecting environment variables
-- and otherwise traversing parents. If no config is found, we supply a default
-- based on current directory.
loadProjectConfig ::
HasTerm env
=> StackYamlLoc
-- ^ Override stack.yaml
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig mstackYaml = getProjectConfig mstackYaml >>= \case
PCProject fp -> do
currDir <- getCurrentDir
logDebug $
"Loading project config file "
<> fromString
(maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp))
PCProject <$> load fp
PCGlobalProject -> do
logDebug "No project config file found, using defaults."
pure PCGlobalProject
PCNoProject extraDeps -> do
logDebug "Ignoring config files"
pure $ PCNoProject extraDeps
where
load fp = do
iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
ProjectAndConfigMonoid project config <- liftIO iopc
pure (project, fp, config)
-- | Get the location of the default user global configuration file.
getDefaultUserConfigPath ::
HasTerm env
=> Path Abs Dir
-> RIO env (Path Abs File)
getDefaultUserConfigPath configRoot = do
let userConfigPath = defaultUserConfigPath configRoot
userConfigExists <- doesFileExist userConfigPath
unless userConfigExists $ do
ensureDir (parent userConfigPath)
liftIO $ writeBinaryFileAtomic userConfigPath defaultConfigYaml
pure userConfigPath
-- | The contents of the default Stack global configuration file.
defaultConfigYaml :: (IsString s, Semigroup s) => s
defaultConfigYaml =
"# This file contains default non-project-specific settings for Stack, used\n\
\# in all projects. For more information about Stack's configuration, see\n\
\# http://docs.haskellstack.org/en/stable/configure/yaml/\n\
\\n\
\# The following parameters are used by 'stack new' to automatically fill fields\n\
\# in the Cabal file. We recommend uncommenting them and filling them out if\n\
\# you intend to use 'stack new'.\n\
\# See https://docs.haskellstack.org/en/stable/configure/yaml/non-project/#templates\n\
\templates:\n\
\ params:\n\
\# author-name:\n\
\# author-email:\n\
\# copyright:\n\
\# github-username:\n\
\\n\
\# The following parameter specifies Stack's output styles; STYLES is a\n\
\# colon-delimited sequence of key=value, where 'key' is a style name and\n\
\# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n\
\# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n\
\# to see the current sequence.\n\
\# stack-colors: STYLES\n"