{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE LambdaCase #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE ViewPatterns #-}

module Stack.Setup

( setupEnv

, ensureCompilerAndMsys

, ensureDockerStackExe

, SetupOpts (..)

, defaultSetupInfoYaml

, withNewLocalBuildTargets

-- * Stack binary download

, StackReleaseInfo

, getDownloadVersion

, stackVersion

, preferredPlatforms

, downloadStackReleaseInfo

, downloadStackExe

) where

import qualified Codec.Archive.Tar as Tar

import Conduit

( ConduitT, await, concatMapMC, filterCE, foldMC, yield )

import Control.Applicative ( empty )

import Crypto.Hash ( SHA1 (..), SHA256 (..) )

import qualified Data.Aeson.KeyMap as KeyMap

import qualified Data.Attoparsec.Text as P

import qualified Data.ByteString as S

import qualified Data.ByteString.Lazy as LBS

import Data.Char ( isDigit )

import qualified Data.Conduit.Binary as CB

import Data.Conduit.Lazy ( lazyConsume )

import qualified Data.Conduit.List as CL

import Data.Conduit.Process.Typed ( createSource )

import Data.Conduit.Zlib ( ungzip )

import Data.List.Split ( splitOn )

import qualified Data.Map as Map

import qualified Data.Set as Set

import qualified Data.Text as T

import qualified Data.Text.Lazy as TL

import qualified Data.Text.Encoding as T

import qualified Data.Text.Lazy.Encoding as TL

import qualified Data.Text.Encoding.Error as T

import qualified Data.Yaml as Yaml

import Distribution.System ( Arch (..), OS, Platform (..) )

import qualified Distribution.System as Cabal

import Distribution.Text ( simpleParse )

import Distribution.Types.PackageName ( mkPackageName )

import Distribution.Version ( mkVersion )

import Network.HTTP.Client ( redirectCount )

import Network.HTTP.StackClient

( CheckHexDigest (..), HashCheck (..), getResponseBody

, getResponseStatusCode, httpLbs, httpJSON, mkDownloadRequest

, parseRequest, parseUrlThrow, setGitHubHeaders

, setHashChecks, setLengthCheck, setRequestMethod

, verifiedDownloadWithProgress, withResponse

)

import Network.HTTP.Simple ( getResponseHeader )

import Pantry.Internal.AesonExtended

( Value (..), WithJSONWarnings (..), logJSONWarnings )

import Path

( (</>), addExtension, dirname, filename, parent, parseAbsDir

, parseAbsFile, parseRelDir, parseRelFile, toFilePath

)

import Path.CheckInstall ( warnInstallSearchPathIssues )

import Path.Extended ( fileExtension )

import Path.Extra ( toFilePathNoTrailingSep )

import Path.IO hiding ( findExecutable, withSystemTempDir )

import RIO.List

( headMaybe, intercalate, intersperse, isPrefixOf

, maximumByMaybe, sort, sortOn, stripPrefix )

import RIO.Process

( EnvVars, HasProcessContext (..), ProcessContext

, augmentPath, augmentPathMap, doesExecutableExist, envVarsL

, exeSearchPathL, getStdout, mkProcessContext, modifyEnvVars

, proc, readProcess_, readProcessStdout, readProcessStdout_

, runProcess, runProcess_, setStdout, waitExitCode

, withModifyEnvVars, withProcessWait, withWorkingDir

, workingDirL

)

import Stack.Build.Haddock ( shouldHaddockDeps )

import Stack.Build.Source ( hashSourceMapData, loadSourceMap )

import Stack.Build.Target ( NeedTargets (..), parseTargets )

import Stack.Constants

( cabalPackageName, hadrianScriptsPosix

, hadrianScriptsWindows, relDirBin, relDirUsr, relFile7zdll

, relFile7zexe, relFileConfigure, relFileLibgmpSo10

, relFileLibgmpSo3, relFileLibncurseswSo6, relFileLibtinfoSo5

, relFileLibtinfoSo6, relFileMainHs, relFileStack

, relFileStackDotExe, relFileStackDotTmp

, relFileStackDotTmpDotExe, usrLibDirs

)

import Stack.Constants.Config ( distRelativeDir )

import Stack.GhcPkg

( createDatabase, getGlobalDB, ghcPkgPathEnvVar

, mkGhcPackagePath )

import Stack.Prelude

import Stack.Setup.Installed

( Tool (..), extraDirs, filterTools, getCompilerVersion

, installDir, listInstalled, markInstalled, tempInstallDir

, toolString, unmarkInstalled

)

import Stack.SourceMap

( actualFromGhc, globalsFromDump, pruneGlobals )

import Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )

import Stack.Types.Build.Exception ( BuildException (..) )

import Stack.Types.BuildConfig

( BuildConfig (..), HasBuildConfig (..), projectRootL

, wantedCompilerVersionL

)

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

import Stack.Types.Compiler

( ActualCompiler (..), CompilerException (..)

, CompilerRepository (..), WhichCompiler (..)

, compilerVersionText, getGhcVersion, isWantedCompiler

, wantedToActual, whichCompiler, whichCompilerL

)

import Stack.Types.CompilerBuild

( CompilerBuild (..), compilerBuildName, compilerBuildSuffix

)

import Stack.Types.CompilerPaths

( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..) )

import Stack.Types.Config

( Config (..), HasConfig (..), envOverrideSettingsL

, ghcInstallHook

)

import Stack.Types.Docker ( dockerStackExeArgName )

import Stack.Types.DownloadInfo ( DownloadInfo (..) )

import Stack.Types.DumpPackage ( DumpPackage (..) )

import Stack.Types.EnvConfig

( EnvConfig (..), HasEnvConfig (..), extraBinDirs

, packageDatabaseDeps, packageDatabaseExtra

, packageDatabaseLocal

)

import Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings )

import Stack.Types.ExtraDirs ( ExtraDirs (..) )

import Stack.Types.GHCDownloadInfo ( GHCDownloadInfo (..) )

import Stack.Types.GHCVariant

( GHCVariant (..), HasGHCVariant (..), ghcVariantName

, ghcVariantSuffix

)

import Stack.Types.Platform

( HasPlatform (..), PlatformVariant (..)

, platformOnlyRelDir )

import Stack.Types.Runner ( HasRunner (..) )

import Stack.Types.SetupInfo ( SetupInfo (..) )

import Stack.Types.SourceMap ( SMActual (..), SourceMap (..) )

import Stack.Types.Version

( VersionCheck, stackMinorVersion, stackVersion )

import Stack.Types.VersionedDownloadInfo

( VersionedDownloadInfo (..) )

import qualified System.Directory as D

import System.Environment ( getExecutablePath, lookupEnv )

import System.IO.Error ( isPermissionError )

import System.FilePath ( searchPathSeparator )

import qualified System.FilePath as FP

import System.Permissions ( osIsWindows, setFileExecutable )

import System.Uname ( getRelease )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Setup" module

data SetupException

= UnsupportedSetupCombo OS Arch

| MissingDependencies [String]

| UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)

| UnknownOSKey Text

| GHCSanityCheckCompileFailed SomeException (Path Abs File)

| WantedMustBeGHC

| RequireCustomGHCVariant

| ProblemWhileDecompressing (Path Abs File)

| SetupInfoMissingSevenz

| DockerStackExeNotFound Version Text

| UnsupportedSetupConfiguration

| MSYS2NotFound Text

| UnwantedCompilerVersion

| UnwantedArchitecture

| GHCInfoNotValidUTF8 UnicodeException

| GHCInfoNotListOfPairs

| GHCInfoMissingGlobalPackageDB

| GHCInfoMissingTargetPlatform

| GHCInfoTargetPlatformInvalid String

| CabalNotFound (Path Abs File)

| HadrianScriptNotFound

| URLInvalid String

| UnknownArchiveExtension String

| Unsupported7z

| TarballInvalid String

| TarballFileInvalid String (Path Abs File)

| UnknownArchiveStructure (Path Abs File)

| StackReleaseInfoNotFound String

| StackBinaryArchiveNotFound [String]

| WorkingDirectoryInvalidBug

| HadrianBindistNotFound

| DownloadAndInstallCompilerError

| StackBinaryArchiveZipUnsupportedBug

| StackBinaryArchiveUnsupported Text

| StackBinaryNotInArchive String Text

| FileTypeInArchiveInvalid Tar.Entry Text

| BinaryUpgradeOnOSUnsupported Cabal.OS

| BinaryUpgradeOnArchUnsupported Cabal.Arch

| ExistingMSYS2NotDeleted (Path Abs Dir) IOException

deriving (Show, Typeable)

instance Exception SetupException where

displayException (UnsupportedSetupCombo os arch) = concat

[ "Error: [S-1852]\n"

, "I don't know how to install GHC for "

, show (os, arch)

, ", please install manually"

]

displayException (MissingDependencies tools) = concat

[ "Error: [S-2126]\n"

, "The following executables are missing and must be installed: "

, intercalate ", " tools

]

displayException (UnknownCompilerVersion oskeys wanted known) = concat

[ "Error: [S-9443]\n"

, "No setup information found for "

, T.unpack $ utf8BuilderToText $ display wanted

, " on your platform.\nThis probably means a GHC bindist has not yet been \

\added for OS key '"

, T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))

, "'.\nSupported versions: "

, T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))

]

displayException (UnknownOSKey oskey) = concat

[ "Error: [S-6810]\n"

, "Unable to find installation URLs for OS key: "

, T.unpack oskey

]

displayException (GHCSanityCheckCompileFailed e ghc) = concat

[ "Error: [S-5159]\n"

, "The GHC located at "

, toFilePath ghc

, " failed to compile a sanity check. Please see:\n\n"

, " http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"

, "for more information. Exception was:\n"

, displayException e

]

displayException WantedMustBeGHC =

"Error: [S-9030]\n"

++ "The wanted compiler must be GHC."

displayException RequireCustomGHCVariant =

"Error: [S-8948]\n"

++ "A custom '--ghc-variant' must be specified to use '--ghc-bindist'."

displayException (ProblemWhileDecompressing archive) = concat

[ "Error: [S-2905]\n"

, "Problem while decompressing "

, toFilePath archive

]

displayException SetupInfoMissingSevenz =

"Error: [S-9561]\n"

++ "SetupInfo missing Sevenz EXE/DLL."

displayException (DockerStackExeNotFound stackVersion' osKey) = concat

[ "Error: [S-1457]\n"

, stackProgName

, "-"

, versionString stackVersion'

, " executable not found for "

, T.unpack osKey

, "\nUse the '"

, T.unpack dockerStackExeArgName

, "' option to specify a location."]

displayException UnsupportedSetupConfiguration =

"Error: [S-7748]\n"

++ "Stack does not know how to install GHC on your system \

\configuration, please install manually."

displayException (MSYS2NotFound osKey) = concat

[ "Error: [S-5308]\n"

, "MSYS2 not found for "

, T.unpack osKey

]

displayException UnwantedCompilerVersion =

"Error: [S-5127]\n"

++ "Not the compiler version we want."

displayException UnwantedArchitecture =

"Error: [S-1540]\n"

++ "Not the architecture we want."

displayException (GHCInfoNotValidUTF8 e) = concat

[ "Error: [S-8668]\n"

, "GHC info is not valid UTF-8: "

, displayException e

]

displayException GHCInfoNotListOfPairs =

"Error: [S-4878]\n"

++ "GHC info does not parse as a list of pairs."

displayException GHCInfoMissingGlobalPackageDB =

"Error: [S-2965]\n"

++ "Key 'Global Package DB' not found in GHC info."

displayException GHCInfoMissingTargetPlatform =

"Error: [S-5219]\n"

++ "Key 'Target platform' not found in GHC info."

displayException (GHCInfoTargetPlatformInvalid targetPlatform) = concat

[ "Error: [S-8299]\n"

, "Invalid target platform in GHC info: "

, targetPlatform

]

displayException (CabalNotFound compiler) = concat

[ "Error: [S-2574]\n"

, "Cabal library not found in global package database for "

, toFilePath compiler

]

displayException HadrianScriptNotFound =

"Error: [S-1128]\n"

++ "No Hadrian build script found."

displayException (URLInvalid url) = concat

[ "Error: [S-1906]\n"

, "`url` must be either an HTTP URL or a file path: "

, url

]

displayException (UnknownArchiveExtension url) = concat

[ "Error: [S-1648]\n"

, "Unknown extension for url: "

, url

]

displayException Unsupported7z =

"Error: [S-4509]\n"

++ "Don't know how to deal with .7z files on non-Windows."

displayException (TarballInvalid name) = concat

[ "Error: [S-3158]\n"

, name

, " must be a tarball file."

]

displayException (TarballFileInvalid name archiveFile) = concat

[ "Error: [S-5252]\n"

, "Invalid "

, name

, " filename: "

, show archiveFile

]

displayException (UnknownArchiveStructure archiveFile) = concat

[ "Error: [S-1827]\n"

, "Expected a single directory within unpacked "

, toFilePath archiveFile

]

displayException (StackReleaseInfoNotFound url) = concat

[ "Error: [S-9476]\n"

, "Could not get release information for Stack from: "

, url

]

displayException (StackBinaryArchiveNotFound platforms) = concat

[ "Error: [S-4461]\n"

, "Unable to find binary Stack archive for platforms: "

, unwords platforms

]

displayException WorkingDirectoryInvalidBug = bugReport "[S-2076]"

"Invalid working directory."

displayException HadrianBindistNotFound =

"Error: [S-6617]\n"

++ "Can't find Hadrian-generated binary distribution."

displayException DownloadAndInstallCompilerError =

"Error: [S-7227]\n"

++ "'downloadAndInstallCompiler' should not be reached with ghc-git."

displayException StackBinaryArchiveZipUnsupportedBug = bugReport "[S-3967]"

"FIXME: Handle zip files."

displayException (StackBinaryArchiveUnsupported archiveURL) = concat

[ "Error: [S-6636]\n"

, "Unknown archive format for Stack archive: "

, T.unpack archiveURL

]

displayException (StackBinaryNotInArchive exeName url) = concat

[ "Error: [S-7871]\n"

, "Stack executable "

, exeName

, " not found in archive from "

, T.unpack url

]

displayException (FileTypeInArchiveInvalid e url) = concat

[ "Error: [S-5046]\n"

, "Invalid file type for tar entry named "

, Tar.entryPath e

, " downloaded from "

, T.unpack url

]

displayException (BinaryUpgradeOnOSUnsupported os) = concat

[ "Error: [S-4132]\n"

, "Binary upgrade not yet supported on OS: "

, show os

]

displayException (BinaryUpgradeOnArchUnsupported arch) = concat

[ "Error: [S-3249]\n"

, "Binary upgrade not yet supported on arch: "

, show arch

]

displayException (ExistingMSYS2NotDeleted destDir e) = concat

[ "Error: [S-4230]\n"

, "Could not delete existing MSYS2 directory: "

, toFilePath destDir

, "\n"

, displayException e

]

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Setup" module

data SetupPrettyException

= GHCInstallFailed

!SomeException

!String

!String

![String]

!(Path Abs Dir)

!(Path Abs Dir)

!(Path Abs Dir)

| InvalidGhcAt !(Path Abs File) !SomeException

| ExecutableNotFound ![Path Abs File]

| SandboxedCompilerNotFound ![String] ![Path Abs Dir]

deriving (Show, Typeable)

instance Pretty SetupPrettyException where

pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =

"[S-7441]"

<> line

<> string (displayException ex)

<> line

<> hang 2 ( fillSep

[ flow "Error encountered while"

, fromString step

, flow "GHC with"

]

<> line

<> style Shell (fromString (unwords (cmd : args)))

<> line

-- TODO: Figure out how to insert \ in the appropriate spots

-- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>

<> fillSep

[ flow "run in"

, pretty wd

]

)

<> blankLine

<> flow "The following directories may now contain files, but won't be \

\used by Stack:"

<> line

<> bulletedList [pretty tempDir, pretty destDir]

<> blankLine

<> fillSep

[ flow "For more information consider rerunning with"

, style Shell "--verbose"

, "flag."

]

<> line

pretty (InvalidGhcAt compiler e) =

"[S-2476]"

<> line

<> fillSep

[ flow "Stack considers the compiler at"

, pretty compiler

, flow "to be invalid."

]

<> blankLine

<> flow "While assessing that compiler, Stack encountered the error:"

<> blankLine

<> ppException e

pretty (ExecutableNotFound toTry) =

"[S-4764]"

<> line

<> flow "Stack could not find any of the following executables:"

<> line

<> bulletedList (map pretty toTry)

pretty (SandboxedCompilerNotFound names fps) =

"[S-9953]"

<> line

<> fillSep

( ( flow "Stack could not find the sandboxed compiler. It looked for \

\one named one of:"

: mkNarrativeList Nothing False

( map fromString names :: [StyleDoc] )

)

<> ( flow "However, it could not find any on one of the paths:"

: mkNarrativeList Nothing False fps

)

)

<> blankLine

<> fillSep

[ flow "Perhaps a previously-installed compiler was not completely \

\uninstalled. For further information about uninstalling \

\tools, see the output of"

, style Shell (flow "stack uninstall") <> "."

]

instance Exception SetupPrettyException

-- | Type representing exceptions thrown by 'performPathChecking'

data PerformPathCheckingException

= ProcessExited ExitCode String [String]

deriving (Show, Typeable)

instance Exception PerformPathCheckingException where

displayException (ProcessExited ec cmd args) = concat

[ "Error: [S-1991]\n"

, "Process exited with "

, displayException ec

, ": "

, unwords (cmd:args)

]

-- | Default location of the stack-setup.yaml file

defaultSetupInfoYaml :: String

defaultSetupInfoYaml =

"https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"

data SetupOpts = SetupOpts

{ soptsInstallIfMissing :: !Bool

, soptsUseSystem :: !Bool

-- ^ Should we use a system compiler installation, if available?

, soptsWantedCompiler :: !WantedCompiler

, soptsCompilerCheck :: !VersionCheck

, soptsStackYaml :: !(Maybe (Path Abs File))

-- ^ If we got the desired GHC version from that file

, soptsForceReinstall :: !Bool

, soptsSanityCheck :: !Bool

-- ^ Run a sanity check on the selected GHC

, soptsSkipGhcCheck :: !Bool

-- ^ Don't check for a compatible GHC version/architecture

, soptsSkipMsys :: !Bool

-- ^ Do not use a custom msys installation on Windows

, soptsResolveMissingGHC :: !(Maybe Text)

-- ^ Message shown to user for how to resolve the missing GHC

, soptsGHCBindistURL :: !(Maybe String)

-- ^ Alternate GHC binary distribution (requires custom GHCVariant)

}

deriving Show

-- | Modify the environment variables (like PATH) appropriately, possibly doing

-- installation too

setupEnv ::

NeedTargets

-> BuildOptsCLI

-> Maybe Text -- ^ Message to give user when necessary GHC is not available

-> RIO BuildConfig EnvConfig

setupEnv needTargets boptsCLI mResolveMissingGHC = do

config <- view configL

bc <- view buildConfigL

let stackYaml = bcStackYaml bc

platform <- view platformL

wcVersion <- view wantedCompilerVersionL

wanted <- view wantedCompilerVersionL

actual <- either throwIO pure $ wantedToActual wanted

let wc = actual^.whichCompilerL

let sopts = SetupOpts

{ soptsInstallIfMissing = configInstallGHC config

, soptsUseSystem = configSystemGHC config

, soptsWantedCompiler = wcVersion

, soptsCompilerCheck = configCompilerCheck config

, soptsStackYaml = Just stackYaml

, soptsForceReinstall = False

, soptsSanityCheck = False

, soptsSkipGhcCheck = configSkipGHCCheck config

, soptsSkipMsys = configSkipMsys config

, soptsResolveMissingGHC = mResolveMissingGHC

, soptsGHCBindistURL = Nothing

}

(compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts

let compilerVer = cpCompilerVersion compilerPaths

-- Modify the initial environment to include the GHC path, if a local GHC

-- is being used

menv0 <- view processContextL

env <- either throwM (pure . removeHaskellEnvVars)

$ augmentPathMap

(map toFilePath $ edBins ghcBin)

(view envVarsL menv0)

menv <- mkProcessContext env

logDebug "Resolving package entries"

(sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do

smActual <- actualFromGhc (bcSMWanted bc) compilerVer

let actualPkgs = Map.keysSet (smaDeps smActual) <>

Map.keysSet (smaProject smActual)

prunedActual = smActual

{ smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }

haddockDeps = shouldHaddockDeps (configBuild config)

targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual

sourceMap <- loadSourceMap targets boptsCLI smActual

sourceMapHash <- hashSourceMapData boptsCLI sourceMap

pure (sourceMap, sourceMapHash)

let envConfig0 = EnvConfig

{ envConfigBuildConfig = bc

, envConfigBuildOptsCLI = boptsCLI

, envConfigSourceMap = sourceMap

, envConfigSourceMapHash = sourceMapHash

, envConfigCompilerPaths = compilerPaths

}

-- extra installation bin directories

mkDirs <- runRIO envConfig0 extraBinDirs

let mpath = Map.lookup "PATH" env

depsPath <-

either throwM pure $ augmentPath (toFilePath <$> mkDirs False) mpath

localsPath <-

either throwM pure $ augmentPath (toFilePath <$> mkDirs True) mpath

deps <- runRIO envConfig0 packageDatabaseDeps

runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps

localdb <- runRIO envConfig0 packageDatabaseLocal

runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) localdb

extras <- runReaderT packageDatabaseExtra envConfig0

let mkGPP locals =

mkGhcPackagePath locals localdb deps extras $ cpGlobalDB compilerPaths

distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath

executablePath <- liftIO getExecutablePath

utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer

mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS"

envRef <- liftIO $ newIORef Map.empty

let getProcessContext' es = do

m <- readIORef envRef

case Map.lookup es m of

Just eo -> pure eo

Nothing -> do

eo <- mkProcessContext

$ Map.insert

"PATH"

(if esIncludeLocals es then localsPath else depsPath)

$ (if esIncludeGhcPackagePath es

then

Map.insert

(ghcPkgPathEnvVar wc)

(mkGPP (esIncludeLocals es))

else id)

$ (if esStackExe es

then Map.insert "STACK_EXE" (T.pack executablePath)

else id)

$ (if esLocaleUtf8 es

then Map.union utf8EnvVars

else id)

$ case (soptsSkipMsys sopts, platform) of

(False, Platform Cabal.I386 Cabal.Windows) ->

Map.insert "MSYSTEM" "MINGW32"

(False, Platform Cabal.X86_64 Cabal.Windows) ->

Map.insert "MSYSTEM" "MINGW64"

_ -> id

-- See https://github.com/commercialhaskell/stack/issues/3444

$ case (esKeepGhcRts es, mGhcRtsEnvVar) of

(True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts)

_ -> id

-- For reasoning and duplication, see:

-- https://github.com/commercialhaskell/stack/issues/70

$ Map.insert

"HASKELL_PACKAGE_SANDBOX"

(T.pack $ toFilePathNoTrailingSep deps)

$ Map.insert "HASKELL_PACKAGE_SANDBOXES"

(T.pack $ if esIncludeLocals es

then intercalate [searchPathSeparator]

[ toFilePathNoTrailingSep localdb

, toFilePathNoTrailingSep deps

, ""

]

else intercalate [searchPathSeparator]

[ toFilePathNoTrailingSep deps

, ""

])

$ Map.insert

"HASKELL_DIST_DIR"

(T.pack $ toFilePathNoTrailingSep distDir)

-- Make sure that any .ghc.environment files

-- are ignored, since we're setting up our

-- own package databases. See

-- https://github.com/commercialhaskell/stack/issues/4706

$ (case cpCompilerVersion compilerPaths of

ACGhc version | version >= mkVersion [8, 4, 4] ->

Map.insert "GHC_ENVIRONMENT" "-"

_ -> id)

env

() <- atomicModifyIORef envRef $ \m' ->

(Map.insert es eo m', ())

pure eo

envOverride <- liftIO $ getProcessContext' minimalEnvSettings

pure EnvConfig

{ envConfigBuildConfig = bc

{ bcConfig = addIncludeLib ghcBin

$ set processContextL envOverride

(view configL bc)

{ configProcessContextSettings = getProcessContext'

}

}

, envConfigBuildOptsCLI = boptsCLI

, envConfigSourceMap = sourceMap

, envConfigSourceMapHash = sourceMapHash

, envConfigCompilerPaths = compilerPaths

}

-- | A modified env which we know has an installed compiler on the PATH.

data WithGHC env = WithGHC !CompilerPaths !env

insideL :: Lens' (WithGHC env) env

insideL = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp)

instance HasLogFunc env => HasLogFunc (WithGHC env) where

logFuncL = insideL.logFuncL

instance HasRunner env => HasRunner (WithGHC env) where

runnerL = insideL.runnerL

instance HasProcessContext env => HasProcessContext (WithGHC env) where

processContextL = insideL.processContextL

instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where

stylesUpdateL = insideL.stylesUpdateL

instance HasTerm env => HasTerm (WithGHC env) where

useColorL = insideL.useColorL

termWidthL = insideL.termWidthL

instance HasPantryConfig env => HasPantryConfig (WithGHC env) where

pantryConfigL = insideL.pantryConfigL

instance HasConfig env => HasPlatform (WithGHC env) where

platformL = configL.platformL

{-# INLINE platformL #-}

platformVariantL = configL.platformVariantL

{-# INLINE platformVariantL #-}

instance HasConfig env => HasGHCVariant (WithGHC env) where

ghcVariantL = configL.ghcVariantL

{-# INLINE ghcVariantL #-}

instance HasConfig env => HasConfig (WithGHC env) where

configL = insideL.configL

instance HasBuildConfig env => HasBuildConfig (WithGHC env) where

buildConfigL = insideL.buildConfigL

instance HasCompiler (WithGHC env) where

compilerPathsL = to (\(WithGHC cp _) -> cp)

-- | Set up a modified environment which includes the modified PATH that GHC can

-- be found on. This is needed for looking up global package information and ghc

-- fingerprint (result from 'ghc --info').

runWithGHC ::

HasConfig env

=> ProcessContext

-> CompilerPaths

-> RIO (WithGHC env) a

-> RIO env a

runWithGHC pc cp inner = do

env <- ask

let envg

= WithGHC cp $

set envOverrideSettingsL (\_ -> pure pc) $

set processContextL pc env

runRIO envg inner

-- | special helper for GHCJS which needs an updated source map

-- only project dependencies should get included otherwise source map hash will

-- get changed and EnvConfig will become inconsistent

rebuildEnv ::

EnvConfig

-> NeedTargets

-> Bool

-> BuildOptsCLI

-> RIO env EnvConfig

rebuildEnv envConfig needTargets haddockDeps boptsCLI = do

let bc = envConfigBuildConfig envConfig

cp = envConfigCompilerPaths envConfig

compilerVer = smCompiler $ envConfigSourceMap envConfig

runRIO (WithGHC cp bc) $ do

smActual <- actualFromGhc (bcSMWanted bc) compilerVer

let actualPkgs =

Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual)

prunedActual = smActual

{ smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }

targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual

sourceMap <- loadSourceMap targets boptsCLI smActual

pure $ envConfig

{ envConfigSourceMap = sourceMap

, envConfigBuildOptsCLI = boptsCLI

}

-- | Some commands (script, ghci and exec) set targets dynamically

-- see also the note about only local targets for rebuildEnv

withNewLocalBuildTargets ::

HasEnvConfig env

=> [Text]

-> RIO env a

-> RIO env a

withNewLocalBuildTargets targets f = do

envConfig <- view envConfigL

haddockDeps <- view $ configL.to configBuild.to shouldHaddockDeps

let boptsCLI = envConfigBuildOptsCLI envConfig

envConfig' <- rebuildEnv envConfig NeedTargets haddockDeps $

boptsCLI {boptsCLITargets = targets}

local (set envConfigL envConfig') f

-- | Add the include and lib paths to the given Config

addIncludeLib :: ExtraDirs -> Config -> Config

addIncludeLib (ExtraDirs _bins includes libs) config = config

{ configExtraIncludeDirs =

configExtraIncludeDirs config ++

map toFilePathNoTrailingSep includes

, configExtraLibDirs =

configExtraLibDirs config ++

map toFilePathNoTrailingSep libs

}

-- | Ensure both the compiler and the msys toolchain are installed and

-- provide the PATHs to add if necessary

ensureCompilerAndMsys ::

(HasBuildConfig env, HasGHCVariant env)

=> SetupOpts

-> RIO env (CompilerPaths, ExtraDirs)

ensureCompilerAndMsys sopts = do

getSetupInfo' <- memoizeRef getSetupInfo

mmsys2Tool <- ensureMsys sopts getSetupInfo'

msysPaths <- maybe (pure Nothing) (fmap Just . extraDirs) mmsys2Tool

actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts

didWarn <- warnUnsupportedCompiler $ getGhcVersion actual

(cp, ghcPaths) <- ensureCompiler sopts getSetupInfo'

warnUnsupportedCompilerCabal cp didWarn

let paths = maybe ghcPaths (ghcPaths <>) msysPaths

pure (cp, paths)

-- | See <https://github.com/commercialhaskell/stack/issues/4246>

warnUnsupportedCompiler :: HasTerm env => Version -> RIO env Bool

warnUnsupportedCompiler ghcVersion =

if

| ghcVersion < mkVersion [7, 8] -> do

prettyWarnL

[ flow "Stack will almost certainly fail with GHC below version 7.8, \

\requested"

, fromString (versionString ghcVersion) <> "."

, flow "Valiantly attempting to run anyway, but I know this is \

\doomed."

, flow "For more information, see:"

, style Url "https://github.com/commercialhaskell/stack/issues/648" <> "."

]

pure True

| ghcVersion >= mkVersion [9, 5] -> do

prettyWarnL

[ flow "Stack has not been tested with GHC versions above 9.6, and \

\using"

, fromString (versionString ghcVersion) <> ","

, flow "this may fail."

]

pure True

| otherwise -> do

logDebug "Asking for a supported GHC version"

pure False

-- | See <https://github.com/commercialhaskell/stack/issues/4246>

warnUnsupportedCompilerCabal ::

HasTerm env

=> CompilerPaths

-> Bool -- ^ already warned about GHC?

-> RIO env ()

warnUnsupportedCompilerCabal cp didWarn = do

unless didWarn $

void $ warnUnsupportedCompiler $ getGhcVersion $ cpCompilerVersion cp

let cabalVersion = cpCabalVersion cp

if

| cabalVersion < mkVersion [1, 19, 2] -> do

prettyWarnL

[ flow "Stack no longer supports Cabal versions below 1.19.2, but \

\version"

, fromString (versionString cabalVersion)

, flow "was found. This invocation will most likely fail. To fix \

\this, either use an older version of Stack or a newer \

\resolver. Acceptable resolvers: lts-3.0/nightly-2015-05-05 \

\or later."

]

| cabalVersion >= mkVersion [3, 9] ->

prettyWarnL

[ flow "Stack has not been tested with Cabal versions above 3.10, \

\but version"

, fromString (versionString cabalVersion)

, flow "was found, this may fail."

]

| otherwise -> pure ()

-- | Ensure that the msys toolchain is installed if necessary and provide the

-- PATHs to add if necessary

ensureMsys ::

HasBuildConfig env

=> SetupOpts

-> Memoized SetupInfo

-> RIO env (Maybe Tool)

ensureMsys sopts getSetupInfo' = do

platform <- view platformL

localPrograms <- view $ configL.to configLocalPrograms

installed <- listInstalled localPrograms

case platform of

Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->

case getInstalledTool installed (mkPackageName "msys2") (const True) of

Just tool -> pure (Just tool)

Nothing

| soptsInstallIfMissing sopts -> do

si <- runMemoized getSetupInfo'

osKey <- getOSKey platform

config <- view configL

VersionedDownloadInfo version info <-

case Map.lookup osKey $ siMsys2 si of

Just x -> pure x

Nothing -> throwIO $ MSYS2NotFound osKey

let tool = Tool (PackageIdentifier (mkPackageName "msys2") version)

Just <$> downloadAndInstallTool

(configLocalPrograms config)

info

tool

(installMsys2Windows si)

| otherwise -> do

prettyWarnS "Continuing despite missing tool: msys2"

pure Nothing

_ -> pure Nothing

installGhcBindist ::

HasBuildConfig env

=> SetupOpts

-> Memoized SetupInfo

-> [Tool]

-> RIO env (Tool, CompilerBuild)

installGhcBindist sopts getSetupInfo' installed = do

Platform expectedArch _ <- view platformL

let wanted = soptsWantedCompiler sopts

isWanted =

isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)

config <- view configL

ghcVariant <- view ghcVariantL

wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted

possibleCompilers <-

case wc of

Ghc -> do

ghcBuilds <- getGhcBuilds

forM ghcBuilds $ \ghcBuild -> do

ghcPkgName <- parsePackageNameThrowing

( "ghc"

++ ghcVariantSuffix ghcVariant

++ compilerBuildSuffix ghcBuild

)

pure (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)

let existingCompilers = concatMap

(\(installedCompiler, compilerBuild) ->

case (installedCompiler, soptsForceReinstall sopts) of

(Just tool, False) -> [(tool, compilerBuild)]

_ -> [])

possibleCompilers

logDebug $

"Found already installed GHC builds: "

<> mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))

case existingCompilers of

(tool, build_):_ -> pure (tool, build_)

[]

| soptsInstallIfMissing sopts -> do

si <- runMemoized getSetupInfo'

downloadAndInstallPossibleCompilers

(map snd possibleCompilers)

si

(soptsWantedCompiler sopts)

(soptsCompilerCheck sopts)

(soptsGHCBindistURL sopts)

| otherwise -> do

let suggestion = fromMaybe

(mconcat

[ "To install the correct GHC into "

, T.pack (toFilePath (configLocalPrograms config))

, ", try running 'stack setup' or use the '--install-ghc' flag."

, " To use your system GHC installation, run \

\'stack config set system-ghc --global true', \

\or use the '--system-ghc' flag."

])

(soptsResolveMissingGHC sopts)

throwM $ CompilerVersionMismatch

Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem)

(soptsWantedCompiler sopts, expectedArch)

ghcVariant

(case possibleCompilers of

[] -> CompilerBuildStandard

(_, compilerBuild):_ -> compilerBuild)

(soptsCompilerCheck sopts)

(soptsStackYaml sopts)

suggestion

-- | Ensure compiler is installed, without worrying about msys

ensureCompiler ::