{-# 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"
