stack-2.9.3.1: src/Stack/Config.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- | 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
, packagesParser
, getImplicitGlobalProjectDir
, getSnapshots
, makeConcreteResolver
, checkOwnership
, getInContainer
, getInNixShell
, defaultConfigYaml
, getProjectConfig
, withBuildConfig
, withNewLogFunc
) where
import Control.Monad.Extra ( firstJustM )
import Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
import Data.ByteString.Builder ( byteString )
import Data.Coerce ( coerce )
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.Text as T
import qualified Data.Yaml as Yaml
import Distribution.System
( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text
import Distribution.Version ( simplifyVersionRange )
import GHC.Conc ( getNumProcessors )
import Network.HTTP.StackClient
( httpJSON, parseUrlThrow, getResponseBody )
import Options.Applicative ( Parser, help, long, metavar, strOption )
import Pantry.Internal.AesonExtended
import Path
import Path.Extra ( toFilePathNoTrailingSep )
import Path.Find ( findInParents )
import Path.IO
import RIO.List ( unzip )
import RIO.Process
import RIO.Time ( toGregorian )
import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Config.Build
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Constants
import Stack.Lock ( lockCachedWanted )
import Stack.Prelude
import Stack.SourceMap
import Stack.Storage.Project ( initProjectStorage )
import Stack.Storage.User ( initUserStorage )
import Stack.Storage.Util ( handleMigrationException )
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Nix
import Stack.Types.Resolver
import Stack.Types.SourceMap
import Stack.Types.Version
( IntersectingVersionRange (..), VersionCheck (..)
, stackVersion, withinRange
)
import System.Console.ANSI
( hSupportsANSIWithoutEmulation, setSGRCode )
import System.Environment
import System.Info.ShortPathName ( getShortPathName )
import System.PosixCompat.Files ( fileOwner, getFileStatus )
import System.Posix.User ( getEffectiveUserID )
-- | If deprecated path exists, use it and print a warning.
-- Otherwise, return the new path.
tryDeprecatedPath ::
HasLogFunc env
=> Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)
-> (Path Abs a -> RIO env Bool) -- ^ Test for existence
-> Path Abs a -- ^ New path
-> Path Abs a -- ^ Deprecated path
-> RIO env (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)
tryDeprecatedPath mWarningDesc exists new old = do
newExists <- exists new
if newExists
then pure (new, True)
else do
oldExists <- exists old
if oldExists
then do
case mWarningDesc of
Nothing -> pure ()
Just desc ->
logWarn $
"Warning: Location of " <> display desc <> " at '" <>
fromString (toFilePath old) <>
"' is deprecated; rename it to '" <>
fromString (toFilePath new) <>
"' instead"
pure (old, True)
else pure (new, False)
-- | Get the location of the implicit global project directory.
-- If the directory already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getImplicitGlobalProjectDir ::
HasLogFunc env
=> Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir config =
--TEST no warning printed
liftM fst $ tryDeprecatedPath
Nothing
doesDirExist
(implicitGlobalProjectDir stackRoot)
(implicitGlobalProjectDirDeprecated stackRoot)
where
stackRoot = view stackRootL config
-- | Download the '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 'AbstractResolver' into a 'Resolver'.
makeConcreteResolver ::
HasConfig env
=> AbstractResolver
-> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver r) = pure r
makeConcreteResolver ar = do
r <-
case ar of
ARGlobal -> do
config <- view configL
implicitGlobalDir <- getImplicitGlobalProjectDir config
let fp = implicitGlobalDir </> stackDotYaml
iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
ProjectAndConfigMonoid project _ <- liftIO iopc
pure $ projectResolver project
ARLatestNightly -> RSLSynonym . Nightly . snapshotsNightly <$> getSnapshots
ARLatestLTSMajor x -> do
snapshots <- getSnapshots
case IntMap.lookup x $ snapshotsLts snapshots of
Nothing -> throwIO $ NoLTSWithMajorVersion x
Just y -> pure $ RSLSynonym $ LTS x y
ARLatestLTS -> do
snapshots <- getSnapshots
if IntMap.null $ snapshotsLts snapshots
then throwIO NoLTSFound
else let (x, y) = IntMap.findMax $ snapshotsLts snapshots
in pure $ RSLSynonym $ LTS x y
logInfo $ "Selected resolver: " <> display r
pure r
-- | Get the latest snapshot resolver available.
getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
getLatestResolver = do
snapshots <- getSnapshots
let mlts = uncurry LTS <$>
listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
pure $ RSLSynonym $ fromMaybe (Nightly (snapshotsNightly snapshots)) mlts
-- Interprets ConfigMonoid options.
configFromConfigMonoid ::
HasRunner env
=> Path Abs Dir -- ^ Stack root, e.g. ~/.stack
-> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
-> ConfigMonoid
-> (Config -> RIO env a)
-> RIO env a
configFromConfigMonoid
configStackRoot configUserConfigPath configResolver
configProject 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 configProject of
PCProject pair -> Just pair
PCGlobalProject -> Nothing
PCNoProject _deps -> Nothing
configAllowLocals =
case configProject of
PCProject _ -> True
PCGlobalProject -> True
PCNoProject _ -> False
configWorkDir0 <- maybe (pure relDirStackWork) (liftIO . parseRelDir) mstackWorkEnv
let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir
configLatestSnapshot = fromFirst
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
configMonoidLatestSnapshot
clConnectionCount = fromFirst 8 configMonoidConnectionCount
configHideTHLoading = fromFirstTrue configMonoidHideTHLoading
configPrefixTimestamps = fromFirst False configMonoidPrefixTimestamps
configGHCVariant = getFirst configMonoidGHCVariant
configCompilerRepository = fromFirst
defaultCompilerRepository
configMonoidCompilerRepository
configGHCBuild = getFirst configMonoidGHCBuild
configInstallGHC = fromFirstTrue configMonoidInstallGHC
configSkipGHCCheck = fromFirstFalse configMonoidSkipGHCCheck
configSkipMsys = fromFirstFalse configMonoidSkipMsys
configExtraIncludeDirs = configMonoidExtraIncludeDirs
configExtraLibDirs = configMonoidExtraLibDirs
configCustomPreprocessorExts = configMonoidCustomPreprocessorExts
configOverrideGccPath = getFirst configMonoidOverrideGccPath
-- 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 configMonoidArch >>= Distribution.Text.simpleParse
os = defOS
configPlatform = Platform arch os
configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion)
configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck
case arch of
OtherArch "aarch64" -> pure ()
OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> displayShow unk
_ -> pure ()
configPlatformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
let configBuild = buildOptsFromMonoid configMonoidBuildOpts
configDocker <-
dockerOptsFromMonoid (fmap fst mproject) configResolver configMonoidDockerOpts
configNix <- nixOptsFromMonoid configMonoidNixOpts os
configSystemGHC <-
case (getFirst configMonoidSystemGHC, nixEnable configNix) of
(Just False, True) ->
throwM NixRequiresSystemGhc
_ ->
pure
(fromFirst
(dockerEnable configDocker || nixEnable configNix)
configMonoidSystemGHC)
when (isJust configGHCVariant && configSystemGHC) $
throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
rawEnv <- liftIO getEnvironment
pathsEnv <- either throwM pure
$ augmentPathMap (map toFilePath configMonoidExtraPath)
(Map.fromList (map (T.pack *** T.pack) rawEnv))
origEnv <- mkProcessContext pathsEnv
let configProcessContextSettings _ = pure origEnv
configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of
Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv
Just path -> pure path
let localProgramsFilePath = toFilePath configLocalProgramsBase
when (osIsWindows && ' ' `elem` localProgramsFilePath) $ do
ensureDir configLocalProgramsBase
-- getShortPathName returns the long path name when a short name does not
-- exist.
shortLocalProgramsFilePath <-
liftIO $ getShortPathName localProgramsFilePath
when (' ' `elem` shortLocalProgramsFilePath) $ do
logError $ "Error: [S-8432]\n"<>
"Stack's 'programs' path contains a space character and has no " <>
"alternative short ('8 dot 3') name. This will cause problems " <>
"with packages that use the GNU project's 'configure' shell " <>
"script. Use the 'local-programs-path' configuration option to " <>
"specify an alternative path. The current path is: " <>
display (T.pack localProgramsFilePath)
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)
let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir
configLocalBin <-
case getFirst configMonoidLocalBinPath 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))
configJobs <-
case getFirst configMonoidJobs of
Nothing -> liftIO getNumProcessors
Just i -> pure i
let configConcurrentTests = fromFirst True configMonoidConcurrentTests
let configTemplateParams = configMonoidTemplateParameters
configScmInit = getFirst configMonoidScmInit
configCabalConfigOpts = coerce configMonoidCabalConfigOpts
configGhcOptionsByName = coerce configMonoidGhcOptionsByName
configGhcOptionsByCat = coerce configMonoidGhcOptionsByCat
configSetupInfoLocations = configMonoidSetupInfoLocations
configSetupInfoInline = configMonoidSetupInfoInline
configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds
configModifyCodePage = fromFirstTrue configMonoidModifyCodePage
configRebuildGhcOptions = fromFirstFalse configMonoidRebuildGhcOptions
configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
configAllowNewer = fromFirst False configMonoidAllowNewer
configAllowNewerDeps = coerce configMonoidAllowNewerDeps
configDefaultTemplate = getFirst configMonoidDefaultTemplate
configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds
configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl
configHideSourcePaths = fromFirstTrue configMonoidHideSourcePaths
configRecommendUpgrade = fromFirstTrue configMonoidRecommendUpgrade
configNoRunCompile = fromFirstFalse configMonoidNoRunCompile
configAllowDifferentUser <-
case getFirst configMonoidAllowDifferentUser of
Just True -> pure True
_ -> getInContainer
configRunner' <- view runnerL
useAnsi <- liftIO $ fromMaybe True <$>
hSupportsANSIWithoutEmulation stderr
let stylesUpdate' = (configRunner' ^. stylesUpdateL) <>
configMonoidStyles
useColor' = runnerUseColor configRunner'
mUseColor = do
colorWhen <- getFirst configMonoidColorWhen
pure $ case colorWhen of
ColorNever -> False
ColorAlways -> True
ColorAuto -> useAnsi
useColor'' = fromMaybe useColor' mUseColor
configRunner'' = configRunner'
& processContextL .~ origEnv
& stylesUpdateL .~ stylesUpdate'
& useColorL .~ useColor''
go = runnerGlobalOpts configRunner'
pic <-
case getFirst configMonoidPackageIndex of
Nothing ->
case getFirst configMonoidPackageIndices of
Nothing -> pure defaultPackageIndexConfig
Just [pic] -> do
logWarn $ fromString packageIndicesWarning
pure pic
Just x -> throwIO $ MultiplePackageIndices x
Just pic -> pure pic
mpantryRoot <- liftIO $ lookupEnv pantryRootEnvVar
pantryRoot <-
case mpantryRoot of
Just dir ->
case parseAbsDir dir of
Nothing -> throwIO $ ParseAbsolutePathException pantryRootEnvVar dir
Just x -> pure x
Nothing -> pure $ configStackRoot </> relDirPantry
let snapLoc =
case getFirst configMonoidSnapshotLocation 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
let configStackDeveloperMode = fromFirst stackDeveloperModeDefault configMonoidStackDeveloperMode
withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
let configRunner = configRunner'' & logFuncL .~ logFunc
withLocalLogFunc logFunc $ handleMigrationException $
withPantryConfig
pantryRoot
pic
(maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
clConnectionCount
(fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
defaultCasaMaxPerRequest
snapLoc
(\configPantryConfig -> initUserStorage
(configStackRoot </> relFileStorage)
(\configUserStorage -> inner Config {..}))
-- | 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 '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 (globalTimeInLog go)
$ setLogMinLevel (globalLogLevel go)
$ setLogVerboseFormat (globalLogLevel go <= LevelDebug)
$ setLogTerminal (globalTerminal go)
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 => (Config -> RIO env a) -> RIO env a
loadConfig inner = do
mstackYaml <- view $ globalOptsL.to globalStackYaml
mproject <- loadProjectConfig mstackYaml
mresolver <- view $ globalOptsL.to globalResolver
configArgs <- view $ globalOptsL.to globalConfigMonoid
(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 {configMonoidDockerOpts =
(configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})
extraConfigs0
let withConfig =
configFromConfigMonoid
stackRoot
userConfigPath
mresolver
mproject'
(mconcat $ configArgs : addConfigMonoid extraConfigs)
withConfig $ \config -> do
unless (stackVersion `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
unless (configAllowDifferentUser config) $ do
unless userOwnsStackRoot $
throwM (UserDoesn'tOwnDirectory stackRoot)
forM_ (configProjectRoot config) $ \dir ->
checkOwnership (dir </> configWorkDir config)
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
config <- ask
-- If provided, turn the AbstractResolver from the command line
-- into a Resolver that can be used below.
-- The configResolver and mcompiler are provided on the command
-- line. In order to properly deal with an AbstractResolver, we
-- need a base directory (to deal with custom snapshot relative
-- paths). We consider the current working directory to be the
-- correct base. Let's calculate the mresolver first.
mresolver <- forM (configResolver config) $ \aresolver -> do
logDebug ("Using resolver: " <> display aresolver <> " specified on command line")
makeConcreteResolver aresolver
(project', stackYamlFP) <- case configProject config of
PCProject (project, fp) -> do
forM_ (projectUserMsg project) (logWarn . fromString)
pure (project, fp)
PCNoProject extraDeps -> do
p <-
case mresolver of
Nothing -> throwIO NoResolverWhenUsingNoProject
Just _ -> getEmptyProject mresolver extraDeps
pure (p, configUserConfigPath config)
PCGlobalProject -> do
logDebug "Run from outside a project, using implicit global project config"
destDir <- getImplicitGlobalProjectDir config
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 configResolver config of
Nothing ->
logDebug $
"Using resolver: " <>
display (projectResolver project) <>
" from implicit global project's config file: " <>
fromString dest'
Just _ -> pure ()
pure (project, dest)
else do
logInfo ("Writing implicit global project config file to: " <> fromString dest')
logInfo "Note: You can change the snapshot via the resolver field there."
p <- getEmptyProject mresolver []
liftIO $ do
writeBinaryFileAtomic dest $ byteString $ S.concat
[ "# This is the implicit global project's config file, which is only used when\n"
, "# '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 $ configUserConfigPath config), "' instead.\n"
, "#\n"
, "# For more information about Stack's configuration, see\n"
, "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
, "#\n"
, Yaml.encode p]
writeBinaryFileAtomic (parent dest </> relFileReadmeTxt) $
"This is the implicit global project, which is " <>
"used only when 'stack' is run\noutside of a " <>
"real project.\n"
pure (p, dest)
mcompiler <- view $ globalOptsL.to globalCompiler
let project = project'
{ projectCompiler = mcompiler <|> projectCompiler project'
, projectResolver = fromMaybe (projectResolver project') mresolver
}
extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
wanted <- lockCachedWanted stackYamlFP (projectResolver project) $
fillProjectWanted stackYamlFP config project
-- Unfortunately redoes getProjectWorkDir, since we don't have a BuildConfig yet
workDir <- view workDirL
let projectStorageFile = parent stackYamlFP </> workDir </> relFileStorage
initProjectStorage projectStorageFile $ \projectStorage -> do
let bc = BuildConfig
{ bcConfig = config
, bcSMWanted = wanted
, bcExtraPackageDBs = extraPackageDBs
, bcStackYaml = stackYamlFP
, bcCurator = projectCurator project
, bcProjectStorage = projectStorage
}
runRIO bc inner
where
getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project
getEmptyProject mresolver extraDeps = do
r <- case mresolver of
Just resolver -> do
logInfo ("Using resolver: " <> display resolver <> " specified on command line")
pure resolver
Nothing -> do
r'' <- getLatestResolver
logInfo ("Using latest snapshot resolver: " <> display r'')
pure r''
pure Project
{ projectUserMsg = Nothing
, projectPackages = []
, projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps
, projectFlags = mempty
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
, projectCurator = Nothing
, projectDropPackages = mempty
}
fillProjectWanted ::
(HasProcessContext env, HasLogFunc env, HasPantryConfig env)
=> Path Abs t
-> Config
-> Project
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages = do
let bopts = configBuild config
packages0 <- for (projectPackages project) $ \fp@(RelFilePath t) -> do
abs' <- resolveDir (parent stackYamlFP) (T.unpack t)
let resolved = ResolvedPath fp abs'
pp <- mkProjectPackage YesPrintWarnings resolved (boptsHaddock bopts)
pure (cpName $ ppCommon pp, 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) (projectDependencies project)
logDebug ("Prefetching git repos: " <> display (T.pack (show gitRepos)))
fetchReposRaw gitRepos
(deps0, mcompleted) <- fmap unzip . forM (projectDependencies project) $ \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 ((cpName $ dpCommon dp, dp), mCompleted)
checkDuplicateNames $
map (second (PLMutable . ppResolvedDir)) packages0 ++
map (second dpLocation) deps0
let packages1 = Map.fromList packages0
snPackages = snapPackages
`Map.difference` packages1
`Map.difference` Map.fromList deps0
`Map.withoutKeys` projectDropPackages project
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 = projectFlags project
packages2 = mergeApply packages1 pFlags $
\_ p flags -> p{ppCommon=(ppCommon p){cpFlags=flags}}
deps2 = mergeApply deps1 pFlags $
\_ d flags -> d{dpCommon=(dpCommon d){cpFlags=flags}}
checkFlagsUsedThrowing pFlags FSStackYaml packages1 deps1
let pkgGhcOptions = configGhcOptionsByName config
deps = mergeApply deps2 pkgGhcOptions $
\_ d options -> d{dpCommon=(dpCommon d){cpGhcOptions=options}}
packages = mergeApply packages2 pkgGhcOptions $
\_ p options -> p{ppCommon=(ppCommon p){cpGhcOptions=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
{ smwCompiler = fromMaybe snapCompiler (projectCompiler project)
, smwProject = packages
, smwDeps = deps
, smwSnapshotLocation = projectResolver project
}
pure (wanted, catMaybes mcompleted)
-- | 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 -> throwM $ 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) <- do
case getFirst (configMonoidStackRoot clArgs) of
Just x -> pure (x, x)
Nothing -> do
mstackRoot <- lookupEnv stackRootEnvVar
case mstackRoot of
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) <- do
mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
case mdirAndOwnership of
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 = do
mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]
case mdirAndOwnership of
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 '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 $ do
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 :: HasLogFunc env
=> Path Abs File -- ^ use config path
-> RIO env [Path Abs File]
getExtraConfigs userConfigPath = do
defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath
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 <|> defaultStackGlobalConfigPath)
-- | 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 = do
eres <- loadYaml parser path
case eres of
Left err -> liftIO $
throwM $ PrettyException (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 = do
eres <- liftIO $ Yaml.decodeFileEither (toFilePath path)
case eres of
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 :: HasLogFunc 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
logInfo "Getting project config file from STACK_YAML environment"
liftM 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 :: HasLogFunc env
=> StackYamlLoc
-- ^ Override stack.yaml
-> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid))
loadProjectConfig mstackYaml = do
mfp <- getProjectConfig mstackYaml
case mfp of
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 Stack configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getDefaultGlobalConfigPath ::
HasLogFunc env
=> RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of
(Just new,Just old) ->
liftM (Just . fst ) $
tryDeprecatedPath
(Just "non-project global configuration file")
doesFileExist
new
old
(Just new,Nothing) -> pure (Just new)
_ -> pure Nothing
-- | Get the location of the default user configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
getDefaultUserConfigPath ::
HasLogFunc env
=> Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath stackRoot = do
(path, exists) <- tryDeprecatedPath
(Just "non-project configuration file")
doesFileExist
(defaultUserConfigPath stackRoot)
(defaultUserConfigPathDeprecated stackRoot)
unless exists $ do
ensureDir (parent path)
liftIO $ writeBinaryFileAtomic path defaultConfigYaml
pure path
packagesParser :: Parser [String]
packagesParser = many (strOption
(long "package" <>
metavar "PACKAGE" <>
help "Add a package (can be specified multiple times)"))
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/yaml_configuration/\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/yaml_configuration/#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"