{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
module Stack.Config
(MiniConfig
,loadConfig
,loadConfigMaybeProject
,loadMiniConfig
,loadConfigYaml
,packagesParser
,getLocalPackages
,getImplicitGlobalProjectDir
,getStackYaml
,getSnapshots
,makeConcreteResolver
,checkOwnership
,getInContainer
,getInNixShell
,defaultConfigYaml
,getProjectConfig
,LocalConfigStatus(..)
) where
import Control.Monad.Extra (firstJustM)
import Stack.Prelude
import Data.Aeson.Extended
import qualified Data.ByteString as S
import Data.Coerce (coerce)
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Monoid
import Data.Monoid.Map (MonoidMap(..))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
import qualified Distribution.Text
import Distribution.Version (simplifyVersionRange, mkVersion')
import GHC.Conc (getNumProcessors)
import Lens.Micro (lens, set)
import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
import Options.Applicative (Parser, strOption, long, help)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.Find (findInParents)
import Path.IO
import qualified Paths_stack as Meta
import Stack.Config.Build
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Config.Urls
import Stack.Constants
import qualified Stack.Image as Image
import Stack.PackageLocation
import Stack.PackageIndex (CabalLoader (..), HasCabalLoader (..))
import Stack.Snapshot
import Stack.Types.BuildPlan
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Nix
import Stack.Types.PackageName (PackageName)
import Stack.Types.PackageIdentifier
import Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..))
import Stack.Types.Resolver
import Stack.Types.Runner
import Stack.Types.Urls
import Stack.Types.Version
import System.Environment
import System.PosixCompat.Files (fileOwner, getFileStatus)
import System.PosixCompat.User (getEffectiveUserID)
import RIO.Process
tryDeprecatedPath
:: HasLogFunc env
=> Maybe T.Text
-> (Path Abs a -> RIO env Bool)
-> Path Abs a
-> Path Abs a
-> RIO env (Path Abs a, Bool)
tryDeprecatedPath mWarningDesc exists new old = do
newExists <- exists new
if newExists
then return (new, True)
else do
oldExists <- exists old
if oldExists
then do
case mWarningDesc of
Nothing -> return ()
Just desc ->
logWarn $
"Warning: Location of " <> display desc <> " at '" <>
fromString (toFilePath old) <>
"' is deprecated; rename it to '" <>
fromString (toFilePath new) <>
"' instead"
return (old, True)
else return (new, False)
getImplicitGlobalProjectDir
:: HasLogFunc env
=> Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir config =
liftM fst $ tryDeprecatedPath
Nothing
doesDirExist
(implicitGlobalProjectDir stackRoot)
(implicitGlobalProjectDirDeprecated stackRoot)
where
stackRoot = view stackRootL config
getStackYaml :: HasConfig env => RIO env (Path Abs File)
getStackYaml = do
config <- view configL
case configMaybeProject config of
Just (_project, stackYaml) -> return stackYaml
Nothing -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir config)
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"
return $ getResponseBody result
makeConcreteResolver
:: HasConfig env
=> Maybe (Path Abs Dir)
-> AbstractResolver
-> RIO env Resolver
makeConcreteResolver root (ARResolver r) = parseCustomLocation root r
makeConcreteResolver root ar = do
snapshots <- getSnapshots
r <-
case ar of
ARResolver r -> assert False $ makeConcreteResolver root $ ARResolver r
ARGlobal -> do
config <- view configL
implicitGlobalDir <- getImplicitGlobalProjectDir config
let fp = implicitGlobalDir </> stackDotYaml
ProjectAndConfigMonoid project _ <-
loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
return $ projectResolver project
ARLatestNightly -> return $ ResolverStackage $ Nightly $ snapshotsNightly snapshots
ARLatestLTSMajor x ->
case IntMap.lookup x $ snapshotsLts snapshots of
Nothing -> throwString $ "No LTS release found with major version " ++ show x
Just y -> return $ ResolverStackage $ LTS x y
ARLatestLTS
| IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found"
| otherwise ->
let (x, y) = IntMap.findMax $ snapshotsLts snapshots
in return $ ResolverStackage $ LTS x y
logInfo $ "Selected resolver: " <> display (resolverRawName r)
return r
getLatestResolver :: HasConfig env => RIO env (ResolverWith a)
getLatestResolver = do
snapshots <- getSnapshots
let mlts = do
(x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
return (LTS x y)
snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts
return (ResolverStackage snap)
configNoLocalConfig
:: HasRunner env
=> Path Abs Dir
-> Maybe AbstractResolver
-> ConfigMonoid
-> RIO env Config
configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig
configNoLocalConfig stackRoot (Just resolver) configMonoid = do
userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver
configFromConfigMonoid
stackRoot
userConfigPath
False
(Just resolver)
Nothing
configMonoid
configFromConfigMonoid
:: HasRunner env
=> Path Abs Dir
-> Path Abs File
-> Bool
-> Maybe AbstractResolver
-> Maybe (Project, Path Abs File)
-> ConfigMonoid
-> RIO env Config
configFromConfigMonoid
clStackRoot configUserConfigPath configAllowLocals mresolver
mproject ConfigMonoid{..} = do
mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar
configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) (liftIO . parseRelDir) mstackWorkEnv
let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir
configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of
(Just url, Nothing) -> do
logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration"
return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url }
_ -> return (urlsFromMonoid configMonoidUrls)
let clConnectionCount = fromFirst 8 configMonoidConnectionCount
configHideTHLoading = fromFirst True configMonoidHideTHLoading
clIndices = fromFirst
[PackageIndex
{ indexName = IndexName "Hackage"
, indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/"
, indexType = ITHackageSecurity HackageSecurity
{ hsKeyIds =
[ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
, "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
, "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"
, "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"
, "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
, "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
, "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"
, "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"
, "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
]
, hsKeyThreshold = 3
}
, indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
, indexRequireHashes = False
}]
configMonoidPackageIndices
configGHCVariant0 = getFirst configMonoidGHCVariant
configGHCBuild = getFirst configMonoidGHCBuild
configInstallGHC = fromFirst True configMonoidInstallGHC
configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck
configSkipMsys = fromFirst False configMonoidSkipMsys
configExtraIncludeDirs = configMonoidExtraIncludeDirs
configExtraLibDirs = configMonoidExtraLibDirs
configOverrideGccPath = getFirst configMonoidOverrideGccPath
configOverrideHpack = maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack
(Platform defArch defOS) = buildPlatform
arch = fromMaybe defArch
$ getFirst configMonoidArch >>= Distribution.Text.simpleParse
os = defOS
configPlatform = Platform arch os
configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion)
configImage = Image.imgOptsFromMonoid configMonoidImageOpts
configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck
case arch of
OtherArch "aarch64" -> return ()
OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> displayShow unk
_ -> return ()
configPlatformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
let configBuild = buildOptsFromMonoid configMonoidBuildOpts
configDocker <-
dockerOptsFromMonoid (fmap fst mproject) clStackRoot mresolver configMonoidDockerOpts
configNix <- nixOptsFromMonoid configMonoidNixOpts os
configSystemGHC <-
case (getFirst configMonoidSystemGHC, nixEnable configNix) of
(Just False, True) ->
throwM NixRequiresSystemGhc
_ ->
return
(fromFirst
(dockerEnable configDocker || nixEnable configNix)
configMonoidSystemGHC)
when (isJust configGHCVariant0 && configSystemGHC) $
throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
rawEnv <- liftIO getEnvironment
pathsEnv <- either throwM return
$ augmentPathMap (map toFilePath configMonoidExtraPath)
(Map.fromList (map (T.pack *** T.pack) rawEnv))
origEnv <- mkProcessContext pathsEnv
let configProcessContextSettings _ = return origEnv
configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of
Nothing -> getDefaultLocalProgramsBase clStackRoot configPlatform origEnv
Just path -> return path
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)
let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir
configLocalBin <-
case getFirst configMonoidLocalBinPath of
Nothing -> do
localDir <- getAppUserDataDir "local"
return $ localDir </> $(mkRelDir "bin")
Just userPath ->
(case mproject of
Nothing -> resolveDir' userPath
Just (_, configYaml) -> resolveDir (parent configYaml) userPath)
`catchAny`
const (throwIO (NoSuchDirectory userPath))
configJobs <-
case getFirst configMonoidJobs of
Nothing -> liftIO getNumProcessors
Just i -> return i
let configConcurrentTests = fromFirst True configMonoidConcurrentTests
let configTemplateParams = configMonoidTemplateParameters
configScmInit = getFirst configMonoidScmInit
configGhcOptionsByName = coerce configMonoidGhcOptionsByName
configGhcOptionsByCat = coerce configMonoidGhcOptionsByCat
configSetupInfoLocations = configMonoidSetupInfoLocations
configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds
configModifyCodePage = fromFirst True configMonoidModifyCodePage
configExplicitSetupDeps = configMonoidExplicitSetupDeps
configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions
configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
configAllowNewer = fromFirst False configMonoidAllowNewer
configDefaultTemplate = getFirst configMonoidDefaultTemplate
configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds
configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl
clIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch
configAllowDifferentUser <-
case getFirst configMonoidAllowDifferentUser of
Just True -> return True
_ -> getInContainer
let configMaybeProject = mproject
configRunner' <- view runnerL
clCache <- newIORef Nothing
clUpdateRef <- newMVar True
let configRunner = set processContextL origEnv configRunner'
configCabalLoader = CabalLoader {..}
return Config {..}
getDefaultLocalProgramsBase :: MonadThrow m
=> Path Abs Dir
-> Platform
-> ProcessContext
-> m (Path Abs Dir)
getDefaultLocalProgramsBase configStackRoot configPlatform override =
let
defaultBase = configStackRoot </> $(mkRelDir "programs")
in
case configPlatform of
Platform _ Windows ->
case Map.lookup "LOCALAPPDATA" $ view envVarsL override of
Just t ->
case parseAbsDir $ T.unpack t of
Nothing -> throwM $ stringException ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t)
Just lad -> return $ lad </> $(mkRelDir "Programs") </> $(mkRelDir stackProgName)
Nothing -> return defaultBase
_ -> return defaultBase
data MiniConfig = MiniConfig
{ mcGHCVariant :: !GHCVariant
, mcConfig :: !Config
}
instance HasConfig MiniConfig where
configL = lens mcConfig (\x y -> x { mcConfig = y })
instance HasProcessContext MiniConfig where
processContextL = configL.processContextL
instance HasCabalLoader MiniConfig where
cabalLoaderL = configL.cabalLoaderL
instance HasPlatform MiniConfig
instance HasGHCVariant MiniConfig where
ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y })
instance HasRunner MiniConfig where
runnerL = configL.runnerL
instance HasLogFunc MiniConfig where
logFuncL = configL.logFuncL
loadMiniConfig :: Config -> MiniConfig
loadMiniConfig config = MiniConfig
{ mcGHCVariant = configGHCVariantDefault config
, mcConfig = config
}
configGHCVariantDefault :: Config -> GHCVariant
configGHCVariantDefault = fromMaybe GHCStandard . configGHCVariant0
loadConfigMaybeProject
:: HasRunner env
=> ConfigMonoid
-> Maybe AbstractResolver
-> LocalConfigStatus (Project, Path Abs File, ConfigMonoid)
-> RIO env LoadConfig
loadConfigMaybeProject configArgs mresolver mproject = do
(stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs
let loadHelper mproject' = do
userConfigPath <- getDefaultUserConfigPath stackRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>=
mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)
let extraConfigs =
map (\c -> c {configMonoidDockerOpts =
(configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})
extraConfigs0
configFromConfigMonoid
stackRoot
userConfigPath
True
mresolver
(fmap (\(x, y, _) -> (x, y)) mproject')
$ mconcat $ configArgs
: maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs
config <-
case mproject of
LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs
LCSProject project -> loadHelper $ Just project
LCSNoProject -> loadHelper Nothing
unless (fromCabalVersion (mkVersion' Meta.version) `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject
unless (configAllowDifferentUser config) $ do
unless userOwnsStackRoot $
throwM (UserDoesn'tOwnDirectory stackRoot)
forM_ mprojectRoot $ \dir ->
checkOwnership (dir </> configWorkDir config)
return LoadConfig
{ lcConfig = config
, lcLoadBuildConfig = runRIO config . loadBuildConfig mproject mresolver
, lcProjectRoot =
case mprojectRoot of
LCSProject fp -> Just fp
LCSNoProject -> Nothing
LCSNoConfig _ -> Nothing
}
loadConfig :: HasRunner env
=> ConfigMonoid
-> Maybe AbstractResolver
-> StackYamlLoc (Path Abs File)
-> RIO env LoadConfig
loadConfig configArgs mresolver mstackYaml =
loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver
loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid)
-> Maybe AbstractResolver
-> Maybe (CompilerVersion 'CVWanted)
-> RIO Config BuildConfig
loadBuildConfig mproject maresolver mcompiler = do
config <- ask
mresolver <- forM maresolver $ \aresolver -> do
let name =
case aresolver of
ARResolver resolver -> resolverRawName resolver
ARLatestNightly -> "nightly"
ARLatestLTS -> "lts"
ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x
ARGlobal -> "global"
logDebug ("Using resolver: " <> display name <> " specified on command line")
base <-
case mproject of
LCSNoConfig parentDir -> return parentDir
LCSProject _ -> resolveDir' "."
LCSNoProject -> resolveDir' "."
makeConcreteResolver (Just base) aresolver
(project', stackYamlFP) <- case mproject of
LCSProject (project, fp, _) -> do
forM_ (projectUserMsg project) (logWarn . fromString)
return (project, fp)
LCSNoConfig _ -> do
p <- assert (isJust mresolver) (getEmptyProject mresolver)
return (p, configUserConfigPath config)
LCSNoProject -> 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
ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest
when (view terminalL config) $
case maresolver of
Nothing ->
logDebug $
"Using resolver: " <>
display (resolverRawName (projectResolver project)) <>
" from implicit global project's config file: " <>
fromString dest'
Just _ -> return ()
return (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
S.writeFile dest' $ 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]
S.writeFile (toFilePath $ parent dest </> $(mkRelFile "README.txt")) $ S.concat
[ "This is the implicit global project, which is used only when 'stack' is run\n"
, "outside of a real project.\n" ]
return (p, dest)
let project = project'
{ projectCompiler = mcompiler <|> projectCompiler project'
, projectResolver = fromMaybe (projectResolver project') mresolver
}
sd0 <- runRIO config $ loadResolver $ projectResolver project
let sd = maybe id setCompilerVersion (projectCompiler project) sd0
extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
return BuildConfig
{ bcConfig = config
, bcSnapshotDef = sd
, bcGHCVariant = configGHCVariantDefault config
, bcPackages = projectPackages project
, bcDependencies = projectDependencies project
, bcExtraPackageDBs = extraPackageDBs
, bcStackYaml = stackYamlFP
, bcFlags = projectFlags project
, bcImplicitGlobal =
case mproject of
LCSNoProject -> True
LCSProject _ -> False
LCSNoConfig _ -> False
}
where
getEmptyProject :: Maybe Resolver -> RIO Config Project
getEmptyProject mresolver = do
r <- case mresolver of
Just resolver -> do
logInfo ("Using resolver: " <> display (resolverRawName resolver) <> " specified on command line")
return resolver
Nothing -> do
r'' <- getLatestResolver
logInfo ("Using latest snapshot resolver: " <> display (resolverRawName r''))
return r''
return Project
{ projectUserMsg = Nothing
, projectPackages = []
, projectDependencies = []
, projectFlags = mempty
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
}
getLocalPackages :: forall env. HasEnvConfig env => RIO env LocalPackages
getLocalPackages = do
cacheRef <- view $ envConfigL.to envConfigPackagesRef
mcached <- liftIO $ readIORef cacheRef
case mcached of
Just cached -> return cached
Nothing -> do
root <- view projectRootL
bc <- view buildConfigL
packages <- do
let withName lpv = (lpvName lpv, lpv)
map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc)
let wrapGPD (gpd, loc) =
let PackageIdentifier name _version =
fromCabalPackageIdentifier
$ C.package
$ C.packageDescription gpd
in (name, (gpd, loc))
deps <- map wrapGPD . concat
<$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc)
checkDuplicateNames $
map (second (PLOther . lpvLoc)) packages ++
map (second snd) deps
return LocalPackages
{ lpProject = Map.fromList packages
, lpDependencies = Map.fromList deps
}
checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m ()
checkDuplicateNames locals =
case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of
[] -> return ()
x -> throwM $ DuplicateLocalPackageNames x
where
hasMultiples (_, _:_:_) = True
hasMultiples _ = False
determineStackRootAndOwnership
:: (MonadIO m)
=> ConfigMonoid
-> m (Path Abs Dir, Bool)
determineStackRootAndOwnership clArgs = liftIO $ do
stackRoot <- do
case getFirst (configMonoidStackRoot clArgs) of
Just x -> return x
Nothing -> do
mstackRoot <- lookupEnv stackRootEnvVar
case mstackRoot of
Nothing -> getAppUserDataDir stackProgName
Just x -> case parseAbsDir x of
Nothing -> throwString ("Failed to parse STACK_ROOT environment variable (expected absolute directory): " ++ show x)
Just parsed -> return parsed
(existingStackRootOrParentDir, userOwnsIt) <- do
mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
case mdirAndOwnership of
Just x -> return x
Nothing -> throwIO (BadStackRoot stackRoot)
when (existingStackRootOrParentDir /= stackRoot) $
if userOwnsIt
then ensureDir stackRoot
else throwIO $
Won'tCreateStackRootInDirectoryOwnedByDifferentUser
stackRoot
existingStackRootOrParentDir
stackRoot' <- canonicalizePath stackRoot
return (stackRoot', userOwnsIt)
checkOwnership :: (MonadIO m) => Path Abs Dir -> m ()
checkOwnership dir = do
mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]
case mdirAndOwnership of
Just (_, True) -> return ()
Just (dir', False) -> throwIO (UserDoesn'tOwnDirectory dir')
Nothing ->
(throwIO . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir
getDirAndOwnership
:: (MonadIO m)
=> Path Abs Dir
-> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership dir = liftIO $ forgivingAbsence $ do
ownership <- isOwnedByUser dir
return (dir, ownership)
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser path = liftIO $ do
if osIsWindows
then return True
else do
fileStatus <- getFileStatus (toFilePath path)
user <- getEffectiveUserID
return (user == fileOwner fileStatus)
getInContainer :: (MonadIO m) => m Bool
getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
getInNixShell :: (MonadIO m) => m Bool
getInNixShell = liftIO (isJust <$> lookupEnv inNixShellEnvVar)
getExtraConfigs :: HasLogFunc env
=> Path Abs File
-> RIO env [Path Abs File]
getExtraConfigs userConfigPath = do
defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath
liftIO $ do
env <- getEnvironment
mstackConfig <-
maybe (return Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_CONFIG" env
mstackGlobalConfig <-
maybe (return Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_GLOBAL_CONFIG" env
filterM doesFileExist
$ fromMaybe userConfigPath mstackConfig
: maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath)
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 (ParseConfigFileException path err)
Right res -> return res
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 -> return (Left err)
Right val ->
case Yaml.parseEither parser val of
Left err -> return (Left (Yaml.AesonException err))
Right (WithJSONWarnings res warnings) -> do
logJSONWarnings (toFilePath path) warnings
return (Right res)
getProjectConfig :: HasLogFunc env
=> StackYamlLoc (Path Abs File)
-> RIO env (LocalConfigStatus (Path Abs File))
getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml
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 LCSProject $ resolveFile' fp
Nothing -> do
currDir <- getCurrentDir
maybe LCSNoProject LCSProject <$> 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 return $ Just fp
else return Nothing
getProjectConfig (SYLNoConfig parentDir) = return (LCSNoConfig parentDir)
data LocalConfigStatus a
= LCSNoProject
| LCSProject a
| LCSNoConfig !(Path Abs Dir)
deriving (Show,Functor,Foldable,Traversable)
loadProjectConfig :: HasLogFunc env
=> StackYamlLoc (Path Abs File)
-> RIO env (LocalConfigStatus (Project, Path Abs File, ConfigMonoid))
loadProjectConfig mstackYaml = do
mfp <- getProjectConfig mstackYaml
case mfp of
LCSProject fp -> do
currDir <- getCurrentDir
logDebug $ "Loading project config file " <>
fromString (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp))
LCSProject <$> load fp
LCSNoProject -> do
logDebug "No project config file found, using defaults."
return LCSNoProject
LCSNoConfig mparentDir -> do
logDebug "Ignoring config files"
return (LCSNoConfig mparentDir)
where
load fp = do
ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
return (project, fp, config)
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) -> return (Just new)
_ -> return Nothing
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 $ S.writeFile (toFilePath path) defaultConfigYaml
return path
getFakeConfigPath
:: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> AbstractResolver
-> m (Path Abs File)
getFakeConfigPath stackRoot ar = do
asString <-
case ar of
ARResolver r -> return $ T.unpack $ resolverRawName r
_ -> throwM $ InvalidResolverForNoLocalConfig $ show ar
asDir <- parseRelDir $ takeWhile (/= ':') asString
let full = stackRoot </> $(mkRelDir "script") </> asDir </> $(mkRelFile "config.yaml")
ensureDir (parent full)
return full
packagesParser :: Parser [String]
packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
defaultConfigYaml :: S.ByteString
defaultConfigYaml = S.intercalate "\n"
[ "# This file contains default non-project-specific settings for 'stack', used"
, "# in all projects. For more information about stack's configuration, see"
, "# http://docs.haskellstack.org/en/stable/yaml_configuration/"
, ""
, "# The following parameters are used by \"stack new\" to automatically fill fields"
, "# in the cabal config. We recommend uncommenting them and filling them out if"
, "# you intend to use 'stack new'."
, "# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates"
, "templates:"
, " params:"
, "# author-name:"
, "# author-email:"
, "# copyright:"
, "# github-username:"
, ""
]