{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE LambdaCase #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RecordWildCards #-}

{-# 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 ( simpleParse )

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

( Value, WithJSONWarnings (..), logJSONWarnings )

import Path

( PathException (..), (</>), parent, parseAbsDir

, parseAbsFile, parseRelDir, stripProperPrefix

)

import Path.Extra ( toFilePathNoTrailingSep )

import Path.Find ( findInParents )

import Path.IO

( XdgDirectory (..), canonicalizePath, doesDirExist

, doesFileExist, ensureDir, forgivingAbsence

, getAppUserDataDir, getCurrentDir, getXdgDir, resolveDir

, resolveDir', resolveFile'

)

import RIO.List ( unzip )

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, defaultGlobalConfigPathDeprecated

, defaultUserConfigPath, defaultUserConfigPathDeprecated

, implicitGlobalProjectDir

, implicitGlobalProjectDirDeprecated, inContainerEnvVar

, inNixShellEnvVar, osIsWindows, pantryRootEnvVar

, platformVariantEnvVar, relDirBin, relDirStackWork

, relFileReadmeTxt, relFileStorage, relDirPantry

, relDirPrograms, relDirStackProgName, relDirUpperPrograms

, stackDeveloperModeDefault, stackDotYaml, stackRootEnvVar

, stackWorkEnvVar, stackXdgEnvVar

)

import Stack.Lock ( lockCachedWanted )

import Stack.Prelude

import Stack.SourceMap

( additionalDepPackage, checkFlagsUsedThrowing

, 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 (..) )

import Stack.Types.BuildConfig ( BuildConfig (..) )

import Stack.Types.BuildOpts ( BuildOpts (..) )

import Stack.Types.ColorWhen ( ColorWhen (..) )

import Stack.Types.Compiler ( defaultCompilerRepository )

import Stack.Types.Config

( Config (..), HasConfig (..), askLatestSnapshotUrl

, configProjectRoot, stackRootL, workDirL

)

import Stack.Types.Config.Exception

( ConfigException (..), ConfigPrettyException (..)

, ParseAbsolutePathException (..), packageIndicesWarning )

import Stack.Types.ConfigMonoid

( ConfigMonoid (..), parseConfigMonoid )

import Stack.Types.Docker ( DockerOptsMonoid (..), dockerEnable )

import Stack.Types.DumpLogs ( DumpLogs (..) )

import Stack.Types.GlobalOpts ( GlobalOpts (..) )

import Stack.Types.Nix ( nixEnable )

import Stack.Types.Platform

( PlatformVariant (..), platformOnlyRelDir )

import Stack.Types.Project ( Project (..) )

import Stack.Types.ProjectAndConfigMonoid

( ProjectAndConfigMonoid (..), parseProjectAndConfigMonoid )

import Stack.Types.ProjectConfig ( ProjectConfig (..) )

import Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )

import Stack.Types.Resolver ( AbstractResolver (..), Snapshots (..) )

import Stack.Types.Runner

( HasRunner (..), Runner (..), globalOptsL, terminalL )

import Stack.Types.SourceMap

( CommonPackage (..), DepPackage (..), ProjectPackage (..)

, SMWanted (..)

)

import Stack.Types.StackYamlLoc ( StackYamlLoc (..) )

import Stack.Types.UnusedFlags ( FlagSource (..) )

import Stack.Types.Version

( IntersectingVersionRange (..), VersionCheck (..)

, stackVersion, withinRange

)

import System.Console.ANSI

( hSupportsANSIWithoutEmulation, setSGRCode )

import System.Environment ( getEnvironment, lookupEnv )

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 ::

HasTerm 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 ->

prettyWarnL

[ flow "Location of"

, flow (T.unpack desc)

, "at"

, style Dir (fromString $ toFilePath old)

, flow "is deprecated; rename it to"

, style Dir (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 ::HasTerm env => Config -> RIO env (Path Abs Dir)

getImplicitGlobalProjectDir config =

--TEST no warning printed

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

prettyInfoL

[ flow "Selected resolver:"

, style Current (fromString $ T.unpack $ textDisplay 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, HasTerm 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 <-

let parseStackWorkEnv x =

catch

(parseRelDir x)

( \e -> case e of

InvalidRelDir _ ->

prettyThrowIO $ StackWorkEnvNotRelativeDir x

_ -> throwIO e

)

in maybe (pure relDirStackWork) (liftIO . parseStackWorkEnv) 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 ->

prettyWarnL

[ flow "Unknown value for architecture setting:"

, style Shell (fromString 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) $

prettyError $

"[S-8432]"

<> line

<> fillSep

[ flow "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"

, style Shell "local-programs-path"

, flow "configuration option to specify an alternative path. \

\The current path is:"

, style File (fromString 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

configApplyProgOptions = fromFirst APOLocals configMonoidApplyProgOptions

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

prettyWarn packageIndicesWarning

pure pic

Just x -> prettyThrowIO $ 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, HasTerm 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) prettyWarnS

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

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 "resolver"

, flow "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

prettyInfoL

[ flow "Using the snapshot"

, style Current (fromString $ T.unpack $ textDisplay resolver)

, flow "specified on the command line."

]

pure resolver

Nothing -> do

r'' <- getLatestResolver

prettyInfoL

[ flow "Using the latest snapshot"

, style Current (fromString $ T.unpack $ textDisplay 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 ::

(HasLogFunc env, HasPantryConfig env, HasProcessContext 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 -> 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) <- 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 $

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 = 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 -> 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 = 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 :: HasTerm env

=> StackYamlLoc

-- ^ Override stack.yaml

-> RIO env (ProjectConfig (Path Abs File))

getProjectConfig (SYLOverride stackYaml) = pure $ PCProject stackYaml

getProjectConfig SYLGlobalProject = pure PCGlobalProject