stack-2.9.3: src/Stack/Setup.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.ByteString as S
import qualified Data.ByteString.Lazy as LBS
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
, verifiedDownloadWithProgress, withResponse
, setRequestMethod
)
import Network.HTTP.Simple ( getResponseHeader )
import Pantry.Internal.AesonExtended
( Value (..), WithJSONWarnings (..), logJSONWarnings )
import Path
( (</>), 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, sortBy, stripPrefix )
import RIO.Process
( EnvVars, HasProcessContext (..), ProcessContext
, augmentPath, augmentPathMap, doesExecutableExist, envVarsL
, exeSearchPathL, getStdout, mkProcessContext, modifyEnvVars
, proc, readProcess_, 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
import Stack.Constants.Config ( distRelativeDir )
import Stack.GhcPkg
( createDatabase, getGlobalDB, ghcPkgPathEnvVar
, mkGhcPackagePath )
import Stack.Prelude
import Stack.SourceMap
import Stack.Setup.Installed
( Tool (..), extraDirs, filterTools, getCompilerVersion
, installDir, listInstalled, markInstalled, tempInstallDir
, toolString, unmarkInstalled
)
import Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.CompilerBuild
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.SourceMap
import Stack.Types.Version
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 ( 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
| InvalidGhcAt (Path Abs File) SomeException
| MSYS2NotFound Text
| UnwantedCompilerVersion
| UnwantedArchitecture
| SandboxedCompilerNotFound
| CompilerNotFound [String]
| 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 (InvalidGhcAt compiler e) = concat
[ "Error: [S-2476]\n"
, "Found an invalid compiler at "
, show (toFilePath compiler)
, ": "
, displayException e
]
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 SandboxedCompilerNotFound =
"Error: [S-9953]\n"
++ "Could not find sandboxed compiler."
displayException (CompilerNotFound toTry) = concat
[ "Error: [S-4764]\n"
, "Could not find any of: "
, show toTry
]
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)
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 ( 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 <>
<> flow "run in" <+> pretty wd
)
<> blankLine
<> flow "The following directories may now contain files, but won't be \
\used by Stack:"
<> line
<> " -" <+> pretty tempDir
<> line
<> " -" <+> pretty destDir
<> blankLine
<> flow "For more information consider rerunning with --verbose flag"
<> line
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)
instance HasConfig env => HasGHCVariant (WithGHC env)
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 :: HasLogFunc env => Version -> RIO env Bool
warnUnsupportedCompiler ghcVersion = do
if
| ghcVersion < mkVersion [7, 8] -> do
logWarn $
"Stack will almost certainly fail with GHC below version 7.8, requested " <>
fromString (versionString ghcVersion)
logWarn "Valiantly attempting to run anyway, but I know this is doomed"
logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"
logWarn ""
pure True
| ghcVersion >= mkVersion [9, 5] -> do
logWarn $
"Stack has not been tested with GHC versions above 9.4, and using " <>
fromString (versionString ghcVersion) <>
", 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
:: HasLogFunc 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
logWarn $ "Stack no longer supports Cabal versions below 1.19.2,"
logWarn $ "but version " <> fromString (versionString cabalVersion) <> " was found."
logWarn "This invocation will most likely fail."
logWarn "To fix this, either use an older version of Stack or a newer resolver"
logWarn "Acceptable resolvers: lts-3.0/nightly-2015-05-05 or later"
| cabalVersion >= mkVersion [3, 9] ->
logWarn $
"Stack has not been tested with Cabal versions above 3.8, but version " <>
fromString (versionString cabalVersion) <>
" 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
logWarn "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
:: forall env. (HasConfig env, HasBuildConfig env, HasGHCVariant env)
=> SetupOpts
-> Memoized SetupInfo
-> RIO env (CompilerPaths, ExtraDirs)
ensureCompiler sopts getSetupInfo' = do
let wanted = soptsWantedCompiler sopts
wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
hook <- ghcInstallHook
hookIsExecutable <- handleIO (\_ -> pure False) $ if osIsWindows
then doesFileExist hook -- can't really detect executable on windows, only file extension
else executable <$> getPermissions hook
Platform expectedArch _ <- view platformL
let canUseCompiler cp
| soptsSkipGhcCheck sopts = pure cp
| not $ isWanted $ cpCompilerVersion cp = throwIO UnwantedCompilerVersion
| cpArch cp /= expectedArch = throwIO UnwantedArchitecture
| otherwise = pure cp
isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
let checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths)
checkCompiler compiler = do
eres <- tryAny $ pathsFromCompiler wc CompilerBuildStandard False compiler >>= canUseCompiler
case eres of
Left e -> do
logDebug $ "Not using compiler at " <> displayShow (toFilePath compiler) <> ": " <> displayShow e
pure Nothing
Right cp -> pure $ Just cp
mcp <-
if | soptsUseSystem sopts -> do
logDebug "Getting system compiler version"
runConduit $
sourceSystemCompilers wanted .|
concatMapMC checkCompiler .|
await
| hookIsExecutable -> do
-- if the hook fails, we fall through to stacks sandboxed installation
hookGHC <- runGHCInstallHook sopts hook
maybe (pure Nothing) checkCompiler hookGHC
| otherwise -> pure Nothing
case mcp of
Nothing -> ensureSandboxedCompiler sopts getSetupInfo'
Just cp -> do
let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] }
pure (cp, paths)
-- | Runs @STACK_ROOT\/hooks\/ghc-install.sh@.
--
-- Reads and possibly validates the output of the process as the GHC
-- binary and returns it.
runGHCInstallHook
:: HasBuildConfig env
=> SetupOpts
-> Path Abs File
-> RIO env (Maybe (Path Abs File))
runGHCInstallHook sopts hook = do
logDebug "Getting hook installed compiler version"
let wanted = soptsWantedCompiler sopts
menv0 <- view processContextL
menv <- mkProcessContext (Map.union (wantedCompilerToEnv wanted) $
removeHaskellEnvVars (view envVarsL menv0))
(exit, out) <- withProcessContext menv $ proc "sh" [toFilePath hook] readProcessStdout
case exit of
ExitSuccess -> do
let ghcPath = stripNewline . TL.unpack . TL.decodeUtf8With T.lenientDecode $ out
case parseAbsFile ghcPath of
Just compiler -> do
when (soptsSanityCheck sopts) $ sanityCheck compiler
logDebug ("Using GHC compiler at: " <> fromString (toFilePath compiler))
pure (Just compiler)
Nothing -> do
logWarn ("Path to GHC binary is not a valid path: " <> fromString ghcPath)
pure Nothing
ExitFailure i -> do
logWarn ("GHC install hook exited with code: " <> fromString (show i))
pure Nothing
where
wantedCompilerToEnv :: WantedCompiler -> EnvVars
wantedCompilerToEnv (WCGhc ver) =
Map.fromList [("HOOK_GHC_TYPE", "bindist")
,("HOOK_GHC_VERSION", T.pack (versionString ver))
]
wantedCompilerToEnv (WCGhcGit commit flavor) =
Map.fromList [("HOOK_GHC_TYPE", "git")
,("HOOK_GHC_COMMIT", commit)
,("HOOK_GHC_FLAVOR", flavor)
,("HOOK_GHC_FLAVOUR", flavor)
]
wantedCompilerToEnv (WCGhcjs ghcjs_ver ghc_ver) =
Map.fromList [("HOOK_GHC_TYPE", "ghcjs")
,("HOOK_GHC_VERSION", T.pack (versionString ghc_ver))
,("HOOK_GHCJS_VERSION", T.pack (versionString ghcjs_ver))
]
newlines :: [Char]
newlines = ['\n', '\r']
stripNewline :: String -> String
stripNewline str = filter (flip notElem newlines) str
ensureSandboxedCompiler
:: HasBuildConfig env
=> SetupOpts
-> Memoized SetupInfo
-> RIO env (CompilerPaths, ExtraDirs)
ensureSandboxedCompiler sopts getSetupInfo' = do
let wanted = soptsWantedCompiler sopts
-- List installed tools
config <- view configL
let localPrograms = configLocalPrograms config
installed <- listInstalled localPrograms
logDebug $ "Installed tools: \n - " <> mconcat (intersperse "\n - " (map (fromString . toolString) installed))
(compilerTool, compilerBuild) <-
case soptsWantedCompiler sopts of
-- shall we build GHC from source?
WCGhcGit commitId flavour -> buildGhcFromSource getSetupInfo' installed (configCompilerRepository config) commitId flavour
_ -> installGhcBindist sopts getSetupInfo' installed
paths <- extraDirs compilerTool
wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
menv0 <- view processContextL
m <- either throwM pure
$ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0)
menv <- mkProcessContext (removeHaskellEnvVars m)
names <-
case wanted of
WCGhc version -> pure ["ghc-" ++ versionString version, "ghc"]
WCGhcGit{} -> pure ["ghc"]
WCGhcjs{} -> throwIO GhcjsNotSupported
-- Previously, we used findExecutable to locate these executables. This was
-- actually somewhat sloppy, as it could discover executables outside of the
-- sandbox. This led to a specific issue on Windows with GHC 9.0.1. See
-- https://gitlab.haskell.org/ghc/ghc/-/issues/20074. Instead, now, we look
-- on the paths specified only.
let loop [] = do
logError $ "Looked for sandboxed compiler named one of: " <> displayShow names
logError $ "Could not find it on the paths " <> displayShow (edBins paths)
throwIO SandboxedCompilerNotFound
loop (x:xs) = do
res <- liftIO $ D.findExecutablesInDirectories (map toFilePath (edBins paths)) x
case res of
[] -> loop xs
compiler:rest -> do
unless (null rest) $ do
logWarn "Found multiple candidate compilers:"
for_ res $ \y -> logWarn $ "- " <> fromString y
logWarn $ "This usually indicates a failed installation. Trying anyway with " <> fromString compiler
parseAbsFile compiler
compiler <- withProcessContext menv $ do
compiler <- loop names
-- Run this here to ensure that the sanity check uses the modified
-- environment, otherwise we may infect GHC_PACKAGE_PATH and break sanity
-- checks.
when (soptsSanityCheck sopts) $ sanityCheck compiler
pure compiler
cp <- pathsFromCompiler wc compilerBuild True compiler
pure (cp, paths)
pathsFromCompiler
:: forall env. HasConfig env
=> WhichCompiler
-> CompilerBuild
-> Bool
-> Path Abs File -- ^ executable filepath
-> RIO env CompilerPaths
pathsFromCompiler wc compilerBuild isSandboxed compiler = withCache $ handleAny onErr $ do
let dir = toFilePath $ parent compiler
suffixNoVersion
| osIsWindows = ".exe"
| otherwise = ""
msuffixWithVersion = do
let prefix =
case wc of
Ghc -> "ghc-"
fmap ("-" ++) $ stripPrefix prefix $ toFilePath $ filename compiler
suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion]
findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
findHelper getNames = do
let toTry = [dir ++ name ++ suffix | suffix <- suffixes, name <- getNames wc]
loop [] = throwIO $ CompilerNotFound toTry
loop (guessedPath':rest) = do
guessedPath <- parseAbsFile guessedPath'
exists <- doesFileExist guessedPath
if exists
then pure guessedPath
else loop rest
logDebug $ "Looking for executable(s): " <> displayShow toTry
loop toTry
pkg <- fmap GhcPkgExe $ findHelper $ \case
Ghc -> ["ghc-pkg"]
menv0 <- view processContextL
menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))
interpreter <- findHelper $
\case
Ghc -> ["runghc"]
haddock <- findHelper $
\case
Ghc -> ["haddock", "haddock-ghc"]
infobs <- proc (toFilePath compiler) ["--info"]
$ fmap (toStrictBytes . fst) . readProcess_
infotext <-
case decodeUtf8' infobs of
Left e -> throwIO $ GHCInfoNotValidUTF8 e
Right info -> pure info
infoPairs :: [(String, String)] <-
case readMaybe $ T.unpack infotext of
Nothing -> throwIO GHCInfoNotListOfPairs
Just infoPairs -> pure infoPairs
let infoMap = Map.fromList infoPairs
eglobaldb <- tryAny $
case Map.lookup "Global Package DB" infoMap of
Nothing -> throwIO GHCInfoMissingGlobalPackageDB
Just db -> parseAbsDir db
arch <-
case Map.lookup "Target platform" infoMap of
Nothing -> throwIO GHCInfoMissingTargetPlatform
Just targetPlatform ->
case simpleParse $ takeWhile (/= '-') targetPlatform of
Nothing -> throwIO $ GHCInfoTargetPlatformInvalid targetPlatform
Just arch -> pure arch
compilerVer <-
case wc of
Ghc ->
case Map.lookup "Project version" infoMap of
Nothing -> do
logWarn "Key 'Project version' not found in GHC info"
getCompilerVersion wc compiler
Just versionString' -> ACGhc <$> parseVersionThrowing versionString'
globaldb <-
case eglobaldb of
Left e -> do
logWarn "Parsing global DB from GHC info failed"
logWarn $ displayShow e
logWarn "Asking ghc-pkg directly"
withProcessContext menv $ getGlobalDB pkg
Right x -> pure x
globalDump <- withProcessContext menv $ globalsFromDump pkg
cabalPkgVer <-
case Map.lookup cabalPackageName globalDump of
Nothing -> throwIO $ CabalNotFound compiler
Just dp -> pure $ pkgVersion $ dpPackageIdent dp
pure CompilerPaths
{ cpBuild = compilerBuild
, cpArch = arch
, cpSandboxed = isSandboxed
, cpCompilerVersion = compilerVer
, cpCompiler = compiler
, cpPkg = pkg
, cpInterpreter = interpreter
, cpHaddock = haddock
, cpCabalVersion = cabalPkgVer
, cpGlobalDB = globaldb
, cpGhcInfo = infobs
, cpGlobalDump = globalDump
}
where
onErr = throwIO . InvalidGhcAt compiler
withCache inner = do
eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed
mres <-
case eres of
Left e -> do
logWarn $ "Trouble loading CompilerPaths cache: " <> displayShow e
pure Nothing
Right x -> pure x
case mres of
Just cp -> cp <$ logDebug "Loaded compiler information from cache"
Nothing -> do
cp <- inner
saveCompilerPaths cp `catchAny` \e ->
logWarn ("Unable to save CompilerPaths cache: " <> displayShow e)
pure cp
buildGhcFromSource :: forall env.
( HasTerm env
, HasProcessContext env
, HasBuildConfig env
) => Memoized SetupInfo -> [Tool] -> CompilerRepository -> Text -> Text
-> RIO env (Tool, CompilerBuild)
buildGhcFromSource getSetupInfo' installed (CompilerRepository url) commitId flavour = do
config <- view configL
let compilerTool = ToolGhcGit commitId flavour
-- detect when the correct GHC is already installed
if compilerTool `elem` installed
then pure (compilerTool,CompilerBuildStandard)
else do
-- clone the repository and execute the given commands
withRepo (SimpleRepo url commitId RepoGit) $ do
-- withRepo is guaranteed to set workingDirL, so let's get it
mcwd <- traverse parseAbsDir =<< view workingDirL
cwd <- maybe (throwIO WorkingDirectoryInvalidBug) pure mcwd
threads <- view $ configL.to configJobs
let
hadrianArgs = fmap T.unpack
[ "-c" -- run ./boot and ./configure
, "-j" <> tshow threads -- parallel build
, "--flavour=" <> flavour -- selected flavour
, "binary-dist"
]
hadrianScripts
| osIsWindows = hadrianScriptsWindows
| otherwise = hadrianScriptsPosix
foundHadrianPaths <- filterM doesFileExist $ (cwd </>) <$> hadrianScripts
hadrianPath <-
maybe (throwIO HadrianScriptNotFound) pure $ listToMaybe foundHadrianPaths
logSticky $ "Building GHC from source with `"
<> display flavour
<> "` flavour. It can take a long time (more than one hour)..."
-- We need to provide an absolute path to the script since
-- the process package only sets working directory _after_
-- discovering the executable
proc (toFilePath hadrianPath) hadrianArgs runProcess_
-- find the bindist and install it
bindistPath <- parseRelDir "_build/bindist"
(_,files) <- listDir (cwd </> bindistPath)
let
isBindist p = do
extension <- fileExtension (filename p)
pure $ "ghc-" `isPrefixOf` (toFilePath (filename p))
&& extension == ".xz"
mbindist <- filterM isBindist files
case mbindist of
[bindist] -> do
let bindist' = T.pack (toFilePath bindist)
dlinfo = DownloadInfo
{ downloadInfoUrl = bindist'
-- we can specify a filepath instead of a URL
, downloadInfoContentLength = Nothing
, downloadInfoSha1 = Nothing
, downloadInfoSha256 = Nothing
}
ghcdlinfo = GHCDownloadInfo mempty mempty dlinfo
installer
| osIsWindows = installGHCWindows
| otherwise = installGHCPosix ghcdlinfo
si <- runMemoized getSetupInfo'
_ <- downloadAndInstallTool
(configLocalPrograms config)
dlinfo
compilerTool
(installer si)
pure (compilerTool, CompilerBuildStandard)
_ -> do
forM_ files (logDebug . fromString . (" - " ++) . toFilePath)
throwIO HadrianBindistNotFound
-- | Determine which GHC builds to use depending on which shared libraries are available
-- on the system.
getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]
getGhcBuilds = do
config <- view configL
case configGHCBuild config of
Just ghcBuild -> pure [ghcBuild]
Nothing -> determineGhcBuild
where
determineGhcBuild = do
-- TODO: a more reliable, flexible, and data driven approach would be to actually download small
-- "test" executables (from setup-info) that link to the same gmp/tinfo versions
-- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go
-- something like this:
--
-- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache
-- if cached, then use that as suffix
-- otherwise:
-- download setup-info
-- go through all with right prefix for os/version/variant
-- first try "standard" (no extra suffix), then the rest
-- download "compatibility check" exe if not already downloaded
-- try running it
-- if successful, then choose that
-- cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version
--
-- Of course, could also try to make a static GHC bindist instead of all this rigamarole.
platform <- view platformL
case platform of
Platform _ Cabal.Linux -> do
-- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well
let sbinEnv m = Map.insert
"PATH"
("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))
m
eldconfigOut
<- withModifyEnvVars sbinEnv
$ proc "ldconfig" ["-p"]
$ tryAny . fmap fst . readProcess_
let firstWords = case eldconfigOut of
Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $
T.lines $ T.decodeUtf8With T.lenientDecode
$ LBS.toStrict ldconfigOut
Left _ -> []
checkLib lib
| libT `elem` firstWords = do
logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output")
pure True
| osIsWindows =
-- Cannot parse /usr/lib on Windows
pure False
| otherwise = do
-- This is a workaround for the fact that libtinfo.so.x doesn't appear in
-- the 'ldconfig -p' output on Arch or Slackware even when it exists.
-- There doesn't seem to be an easy way to get the true list of directories
-- to scan for shared libs, but this works for our particular cases.
matches <- filterM (doesFileExist .(</> lib)) usrLibDirs
case matches of
[] -> logDebug ("Did not find shared library " <> libD)
>> pure False
(path:_) -> logDebug ("Found shared library " <> libD
<> " in " <> fromString (Path.toFilePath path))
>> pure True
where
libT = T.pack (toFilePath lib)
libD = fromString (toFilePath lib)
hastinfo5 <- checkLib relFileLibtinfoSo5
hastinfo6 <- checkLib relFileLibtinfoSo6
hasncurses6 <- checkLib relFileLibncurseswSo6
hasgmp5 <- checkLib relFileLibgmpSo10
hasgmp4 <- checkLib relFileLibgmpSo3
let libComponents = concat
[ [["tinfo6"] | hastinfo6 && hasgmp5]
, [[] | hastinfo5 && hasgmp5]
, [["ncurses6"] | hasncurses6 && hasgmp5 ]
, [["gmp4"] | hasgmp4 ]
]
useBuilds $ map
(\c -> case c of
[] -> CompilerBuildStandard
_ -> CompilerBuildSpecialized (intercalate "-" c))
libComponents
Platform _ Cabal.FreeBSD -> do
let getMajorVer = readMaybe <=< headMaybe . (splitOn ".")
majorVer <- getMajorVer <$> sysRelease
if majorVer >= Just (12 :: Int) then
useBuilds [CompilerBuildSpecialized "ino64"]
else
useBuilds [CompilerBuildStandard]
Platform _ Cabal.OpenBSD -> do
releaseStr <- mungeRelease <$> sysRelease
useBuilds [CompilerBuildSpecialized releaseStr]
_ -> useBuilds [CompilerBuildStandard]
useBuilds builds = do
logDebug $
"Potential GHC builds: " <>
mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))
pure builds
-- | Encode an OpenBSD version (like "6.1") into a valid argument for
-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed
-- with "r".
-- The result r must be such that "ghc-" ++ r is a valid package name,
-- as recognized by parsePackageNameFromString.
mungeRelease :: String -> String
mungeRelease = intercalate "-" . prefixMaj . splitOn "."
where
prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs
prefixFst _ _ [] = []
prefixMaj = prefixFst "maj" prefixMin
prefixMin = prefixFst "min" (map ('r':))
sysRelease :: HasLogFunc env => RIO env String
sysRelease =
handleIO (\e -> do
logWarn $ "Could not query OS version: " <> displayShow e
pure "")
(liftIO getRelease)
-- | Ensure Docker container-compatible 'stack' executable is downloaded
ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe containerPlatform = do
config <- view configL
containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
let programsPath = configLocalProgramsBase config </> containerPlatformDir
tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion)
stackExeDir <- installDir programsPath tool
let stackExePath = stackExeDir </> relFileStack
stackExeExists <- doesFileExist stackExePath
unless stackExeExists $ do
logInfo $
"Downloading Docker-compatible " <>
fromString stackProgName <>
" executable"
sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion))
platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)
downloadStackExe platforms sri stackExeDir False (const $ pure ())
pure stackExePath
-- | Get all executables on the path that might match the wanted compiler
sourceSystemCompilers
:: (HasProcessContext env, HasLogFunc env)
=> WantedCompiler
-> ConduitT i (Path Abs File) (RIO env) ()
sourceSystemCompilers wanted = do
searchPath <- view exeSearchPathL
names <-
case wanted of
WCGhc version -> pure
[ "ghc-" ++ versionString version
, "ghc"
]
WCGhcjs{} -> throwIO GhcjsNotSupported
WCGhcGit{} -> pure [] -- only use sandboxed versions
for_ names $ \name -> for_ searchPath $ \dir -> do
fp <- resolveFile' $ addExe $ dir FP.</> name
exists <- doesFileExist fp
when exists $ yield fp
where
addExe
| osIsWindows = (++ ".exe")
| otherwise = id
-- | Download the most recent SetupInfo
getSetupInfo :: HasConfig env => RIO env SetupInfo
getSetupInfo = do
config <- view configL
let inlineSetupInfo = configSetupInfoInline config
locations' = configSetupInfoLocations config
locations = if null locations' then [defaultSetupInfoYaml] else locations'
resolvedSetupInfos <- mapM loadSetupInfo locations
pure (inlineSetupInfo <> mconcat resolvedSetupInfos)
where
loadSetupInfo urlOrFile = do
bs <-
case parseUrlThrow urlOrFile of
Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req
Nothing -> liftIO $ S.readFile urlOrFile
WithJSONWarnings si warnings <- either throwM pure (Yaml.decodeEither' bs)
when (urlOrFile /= defaultSetupInfoYaml) $
logJSONWarnings urlOrFile warnings
pure si
getInstalledTool :: [Tool] -- ^ already installed
-> PackageName -- ^ package to find
-> (Version -> Bool) -- ^ which versions are acceptable
-> Maybe Tool
getInstalledTool installed name goodVersion = Tool <$>
maximumByMaybe (comparing pkgVersion) (filterTools name goodVersion installed)
downloadAndInstallTool :: (HasTerm env, HasBuildConfig env)
=> Path Abs Dir
-> DownloadInfo
-> Tool
-> (Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())
-> RIO env Tool
downloadAndInstallTool programsDir downloadInfo tool installer = do
ensureDir programsDir
(file, at) <- downloadFromInfo programsDir downloadInfo tool
dir <- installDir programsDir tool
tempDir <- tempInstallDir programsDir tool
liftIO $ ignoringAbsence (removeDirRecur tempDir)
ensureDir tempDir
unmarkInstalled programsDir tool
installer file at tempDir dir
markInstalled programsDir tool
liftIO $ ignoringAbsence (removeDirRecur tempDir)
pure tool
downloadAndInstallCompiler :: (HasBuildConfig env, HasGHCVariant env)
=> CompilerBuild
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe String
-> RIO env Tool
downloadAndInstallCompiler ghcBuild si wanted@(WCGhc version) versionCheck mbindistURL = do
ghcVariant <- view ghcVariantL
(selectedVersion, downloadInfo) <- case mbindistURL of
Just bindistURL -> do
case ghcVariant of
GHCCustom _ -> pure ()
_ -> throwM RequireCustomGHCVariant
pure (version, GHCDownloadInfo mempty mempty DownloadInfo
{ downloadInfoUrl = T.pack bindistURL
, downloadInfoContentLength = Nothing
, downloadInfoSha1 = Nothing
, downloadInfoSha256 = Nothing
})
_ -> do
ghcKey <- getGhcKey ghcBuild
case Map.lookup ghcKey $ siGHCs si of
Nothing -> throwM $ UnknownOSKey ghcKey
Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_
config <- view configL
let installer =
case configPlatform config of
Platform _ Cabal.Windows -> installGHCWindows
_ -> installGHCPosix downloadInfo
logInfo $
"Preparing to install GHC" <>
(case ghcVariant of
GHCStandard -> ""
v -> " (" <> fromString (ghcVariantName v) <> ")") <>
(case ghcBuild of
CompilerBuildStandard -> ""
b -> " (" <> fromString (compilerBuildName b) <> ")") <>
" to an isolated location."
logInfo "This will not interfere with any system-level installation."
ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
downloadAndInstallTool (configLocalPrograms config) (gdiDownloadInfo downloadInfo) tool (installer si)
downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO GhcjsNotSupported
downloadAndInstallCompiler _ _ WCGhcGit{} _ _ =
throwIO DownloadAndInstallCompilerError
getWantedCompilerInfo :: (Ord k, MonadThrow m)
=> Text
-> VersionCheck
-> WantedCompiler
-> (k -> ActualCompiler)
-> Map k a
-> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs_ =
case mpair of
Just pair -> pure pair
Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_))
where
mpair =
listToMaybe $
sortBy (flip (comparing fst)) $
filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)
-- | Download and install the first available compiler build.
downloadAndInstallPossibleCompilers
:: (HasGHCVariant env, HasBuildConfig env)
=> [CompilerBuild]
-> SetupInfo
-> WantedCompiler
-> VersionCheck
-> Maybe String
-> RIO env (Tool, CompilerBuild)
downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL =
go possibleCompilers Nothing
where
-- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or
-- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is nonexistent,
-- not if the download or install fails for some other reason).
-- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception
-- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any
-- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions
-- are unioned).
go [] Nothing = throwM UnsupportedSetupConfiguration
go [] (Just e) = throwM e
go (b:bs) e = do
logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b)
er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL
case er of
Left e'@(UnknownCompilerVersion ks' w' vs') ->
case e of
Nothing -> go bs (Just e')
Just (UnknownOSKey k) ->
go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs'
Just (UnknownCompilerVersion ks _ vs) ->
go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs)
Just x -> throwM x
Left e'@(UnknownOSKey k') ->
case e of
Nothing -> go bs (Just e')
Just (UnknownOSKey _) -> go bs e
Just (UnknownCompilerVersion ks w vs) ->
go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs
Just x -> throwM x
Left e' -> throwM e'
Right r -> pure (r, b)
getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
=> CompilerBuild -> m Text
getGhcKey ghcBuild = do
ghcVariant <- view ghcVariantL
platform <- view platformL
osKey <- getOSKey platform
pure $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)
getOSKey :: (MonadThrow m)
=> Platform -> m Text
getOSKey platform =
case platform of
Platform I386 Cabal.Linux -> pure "linux32"
Platform X86_64 Cabal.Linux -> pure "linux64"
Platform I386 Cabal.OSX -> pure "macosx"
Platform X86_64 Cabal.OSX -> pure "macosx"
Platform I386 Cabal.FreeBSD -> pure "freebsd32"
Platform X86_64 Cabal.FreeBSD -> pure "freebsd64"
Platform I386 Cabal.OpenBSD -> pure "openbsd32"
Platform X86_64 Cabal.OpenBSD -> pure "openbsd64"
Platform I386 Cabal.Windows -> pure "windows32"
Platform X86_64 Cabal.Windows -> pure "windows64"
Platform Arm Cabal.Linux -> pure "linux-armv7"
Platform AArch64 Cabal.Linux -> pure "linux-aarch64"
Platform Sparc Cabal.Linux -> pure "linux-sparc"
Platform AArch64 Cabal.OSX -> pure "macosx-aarch64"
Platform AArch64 Cabal.FreeBSD -> pure "freebsd-aarch64"
Platform arch os -> throwM $ UnsupportedSetupCombo os arch
downloadOrUseLocal
:: (HasTerm env, HasBuildConfig env)
=> Text -> DownloadInfo -> Path Abs File -> RIO env (Path Abs File)
downloadOrUseLocal downloadLabel downloadInfo destination =
case url of
(parseUrlThrow -> Just _) -> do
ensureDir (parent destination)
chattyDownload downloadLabel downloadInfo destination
pure destination
(parseAbsFile -> Just path) -> do
warnOnIgnoredChecks
pure path
(parseRelFile -> Just path) -> do
warnOnIgnoredChecks
root <- view projectRootL
pure (root </> path)
_ -> throwIO $ URLInvalid url
where
url = T.unpack $ downloadInfoUrl downloadInfo
warnOnIgnoredChecks = do
let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1,
downloadInfoSha256=sha256} = downloadInfo
when (isJust contentLength) $
logWarn "`content-length` is not checked and should not be specified when `url` is a file path"
when (isJust sha1) $
logWarn "`sha1` is not checked and should not be specified when `url` is a file path"
when (isJust sha256) $
logWarn "`sha256` is not checked and should not be specified when `url` is a file path"
downloadFromInfo
:: (HasTerm env, HasBuildConfig env)
=> Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)
downloadFromInfo programsDir downloadInfo tool = do
archiveType <-
case extension of
".tar.xz" -> pure TarXz
".tar.bz2" -> pure TarBz2
".tar.gz" -> pure TarGz
".7z.exe" -> pure SevenZ
_ -> throwIO $ UnknownArchiveExtension url
relativeFile <- parseRelFile $ toolString tool ++ extension
let destinationPath = programsDir </> relativeFile
localPath <- downloadOrUseLocal (T.pack (toolString tool)) downloadInfo destinationPath
pure (localPath, archiveType)
where
url = T.unpack $ downloadInfoUrl downloadInfo
extension = loop url
where
loop fp
| ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
| otherwise = ""
where
(fp', ext) = FP.splitExtension fp
data ArchiveType
= TarBz2
| TarXz
| TarGz
| SevenZ
installGHCPosix :: HasConfig env
=> GHCDownloadInfo
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCPosix downloadInfo _ archiveFile archiveType tempDir destDir = do
platform <- view platformL
menv0 <- view processContextL
menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))
logDebug $ "menv = " <> displayShow (view envVarsL menv)
(zipTool', compOpt) <-
case archiveType of
TarXz -> pure ("xz", 'J')
TarBz2 -> pure ("bzip2", 'j')
TarGz -> pure ("gzip", 'z')
SevenZ -> throwIO Unsupported7z
-- Slight hack: OpenBSD's tar doesn't support xz.
-- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986
let tarDep =
case (platform, archiveType) of
(Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"
_ -> checkDependency "tar"
(zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
<$> checkDependency zipTool'
<*> (checkDependency "gmake" <|> checkDependency "make")
<*> tarDep
logDebug $ "ziptool: " <> fromString zipTool
logDebug $ "make: " <> fromString makeTool
logDebug $ "tar: " <> fromString tarTool
let runStep step wd env cmd args = do
menv' <- modifyEnvVars menv (Map.union env)
let logLines lvl = CB.lines .| CL.mapM_ (lvl . displayBytesUtf8)
logStdout = logLines logDebug
logStderr = logLines logError
void $ withWorkingDir (toFilePath wd) $
withProcessContext menv' $
sinkProcessStderrStdout cmd args logStderr logStdout
`catchAny` \ex ->
throwIO $ PrettyException
(GHCInstallFailed ex step cmd args wd tempDir destDir)
logSticky $
"Unpacking GHC into " <>
fromString (toFilePath tempDir) <>
" ..."
logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)
runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile]
dir <- expectSingleUnpackedDir archiveFile tempDir
mOverrideGccPath <- view $ configL.to configOverrideGccPath
-- The make application uses the CC environment variable to configure the
-- program for compiling C programs
let mGccEnv = let gccEnvFromPath p =
Map.singleton "CC" $ T.pack (toFilePath p)
in gccEnvFromPath <$> mOverrideGccPath
-- Data.Map.union provides a left-biased union, so mGccEnv will prevail
let ghcConfigureEnv =
fromMaybe Map.empty mGccEnv `Map.union` gdiConfigureEnv downloadInfo
logSticky "Configuring GHC ..."
runStep "configuring" dir
ghcConfigureEnv
(toFilePath $ dir </> relFileConfigure)
(("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo))
logSticky "Installing GHC ..."
runStep "installing" dir mempty makeTool ["install"]
logStickyDone $ "Installed GHC."
logDebug $ "GHC installed to " <> fromString (toFilePath destDir)
-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: CheckDependency env a -> RIO env a
checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) pure
checkDependency :: HasProcessContext env => String -> CheckDependency env String
checkDependency tool = CheckDependency $ do
exists <- doesExecutableExist tool
pure $ if exists then Right tool else Left [tool]
newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))
deriving Functor
instance Applicative (CheckDependency env) where
pure x = CheckDependency $ pure (Right x)
CheckDependency f <*> CheckDependency x = CheckDependency $ do
f' <- f
x' <- x
pure $
case (f', x') of
(Left e1, Left e2) -> Left $ e1 ++ e2
(Left e, Right _) -> Left e
(Right _, Left e) -> Left e
(Right f'', Right x'') -> Right $ f'' x''
instance Alternative (CheckDependency env) where
empty = CheckDependency $ pure $ Left []
CheckDependency x <|> CheckDependency y = CheckDependency $ do
res1 <- x
case res1 of
Left _ -> y
Right x' -> pure $ Right x'
installGHCWindows :: HasBuildConfig env
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installGHCWindows si archiveFile archiveType _tempDir destDir = do
withUnpackedTarball7z "GHC" si archiveFile archiveType destDir
logInfo $ "GHC installed to " <> fromString (toFilePath destDir)
installMsys2Windows :: HasBuildConfig env
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> Path Abs Dir
-> RIO env ()
installMsys2Windows si archiveFile archiveType _tempDir destDir = do
exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do
throwM $ ExistingMSYS2NotDeleted destDir e
withUnpackedTarball7z "MSYS2" si archiveFile archiveType destDir
-- I couldn't find this officially documented anywhere, but you need to run
-- the MSYS shell once in order to initialize some pacman stuff. Once that
-- run happens, you can just run commands as usual.
menv0 <- view processContextL
newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"
newEnv <- either throwM pure $ augmentPathMap
[toFilePath $ destDir </> relDirUsr </> relDirBin]
(view envVarsL newEnv0)
menv <- mkProcessContext newEnv
withWorkingDir (toFilePath destDir) $ withProcessContext menv
$ proc "sh" ["--login", "-c", "true"] runProcess_
-- No longer installing git, it's unreliable
-- (https://github.com/commercialhaskell/stack/issues/1046) and the
-- MSYS2-installed version has bad CRLF defaults.
--
-- Install git. We could install other useful things in the future too.
-- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing
-- | Unpack a compressed tarball using 7zip. Expects a single directory in
-- the unpacked results, which is renamed to the destination directory.
withUnpackedTarball7z :: HasBuildConfig env
=> String -- ^ Name of tool, used in error messages
-> SetupInfo
-> Path Abs File -- ^ Path to archive file
-> ArchiveType
-> Path Abs Dir -- ^ Destination directory.
-> RIO env ()
withUnpackedTarball7z name si archiveFile archiveType destDir = do
suffix <-
case archiveType of
TarXz -> pure ".xz"
TarBz2 -> pure ".bz2"
TarGz -> pure ".gz"
_ -> throwIO $ TarballInvalid name
tarFile <-
case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of
Nothing -> throwIO $ TarballFileInvalid name archiveFile
Just x -> parseRelFile $ T.unpack x
run7z <- setup7z si
let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"
ensureDir (parent destDir)
withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do
liftIO $ ignoringAbsence (removeDirRecur destDir)
run7z tmpDir archiveFile
run7z tmpDir (tmpDir </> tarFile)
absSrcDir <- expectSingleUnpackedDir archiveFile tmpDir
renameDir absSrcDir destDir
expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)
expectSingleUnpackedDir archiveFile destDir = do
contents <- listDir destDir
case contents of
([dir], _ ) -> pure dir
_ -> throwIO $ UnknownArchiveStructure archiveFile
-- | Download 7z as necessary, and get a function for unpacking things.
--
-- Returned function takes an unpack directory and archive.
setup7z :: (HasBuildConfig env, MonadIO m)
=> SetupInfo
-> RIO env (Path Abs Dir -> Path Abs File -> m ())
setup7z si = do
dir <- view $ configL.to configLocalPrograms
ensureDir dir
let exeDestination = dir </> relFile7zexe
dllDestination = dir </> relFile7zdll
case (siSevenzDll si, siSevenzExe si) of
(Just sevenzDll, Just sevenzExe) -> do
_ <- downloadOrUseLocal "7z.dll" sevenzDll dllDestination
exePath <- downloadOrUseLocal "7z.exe" sevenzExe exeDestination
withRunInIO $ \run -> pure $ \outdir archive -> liftIO $ run $ do
let cmd = toFilePath exePath
args =
[ "x"
, "-o" ++ toFilePath outdir
, "-y"
, toFilePath archive
]
let archiveDisplay = fromString $ FP.takeFileName $ toFilePath archive
isExtract = FP.takeExtension (toFilePath archive) == ".tar"
logInfo $
(if isExtract then "Extracting " else "Decompressing ") <>
archiveDisplay <> "..."
ec <-
proc cmd args $ \pc ->
if isExtract
then withProcessWait (setStdout createSource pc) $ \p -> do
total <- runConduit
$ getStdout p
.| filterCE (== 10) -- newline characters
.| foldMC
(\count bs -> do
let count' = count + S.length bs
logSticky $ "Extracted " <> display count' <> " files"
pure count'
)
0
logStickyDone $
"Extracted total of " <>
display total <>
" files from " <>
archiveDisplay
waitExitCode p
else runProcess pc
when (ec /= ExitSuccess)
$ liftIO $ throwM (ProblemWhileDecompressing archive)
_ -> throwM SetupInfoMissingSevenz
chattyDownload :: HasTerm env
=> Text -- ^ label
-> DownloadInfo -- ^ URL, content-length, sha1, and sha256
-> Path Abs File -- ^ destination
-> RIO env ()
chattyDownload label downloadInfo path = do
let url = downloadInfoUrl downloadInfo
req <- parseUrlThrow $ T.unpack url
logSticky $
"Preparing to download " <>
display label <>
" ..."
logDebug $
"Downloading from " <>
display url <>
" to " <>
fromString (toFilePath path) <>
" ..."
hashChecks <- fmap catMaybes $ forM
[ ("sha1", HashCheck SHA1, downloadInfoSha1)
, ("sha256", HashCheck SHA256, downloadInfoSha256)
]
$ \(name, constr, getter) ->
case getter downloadInfo of
Just bs -> do
logDebug $
"Will check against " <>
name <>
" hash: " <>
displayBytesUtf8 bs
pure $ Just $ constr $ CheckHexDigestByteString bs
Nothing -> pure Nothing
when (null hashChecks) $ logWarn $
"No sha1 or sha256 found in metadata," <>
" download hash won't be checked."
let dReq = setHashChecks hashChecks $
setLengthCheck mtotalSize $
mkDownloadRequest req
x <- verifiedDownloadWithProgress dReq path label mtotalSize
if x
then logStickyDone ("Downloaded " <> display label <> ".")
else logStickyDone "Already downloaded."
where
mtotalSize = downloadInfoContentLength downloadInfo
-- | Perform a basic sanity check of GHC
sanityCheck :: (HasProcessContext env, HasLogFunc env)
=> Path Abs File -> RIO env ()
sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do
let fp = toFilePath $ dir </> relFileMainHs
liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines
[ "import Distribution.Simple" -- ensure Cabal library is present
, "main = putStrLn \"Hello World\""
]
logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc)
eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc)
[ fp
, "-no-user-package-db"
] $ try . readProcess_
case eres of
Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc
Right _ -> pure () -- TODO check that the output of running the command is correct
-- Remove potentially confusing environment variables
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
Map.delete "GHC_PACKAGE_PATH" .
Map.delete "GHC_ENVIRONMENT" .
Map.delete "HASKELL_PACKAGE_SANDBOX" .
Map.delete "HASKELL_PACKAGE_SANDBOXES" .
Map.delete "HASKELL_DIST_DIR" .
-- https://github.com/commercialhaskell/stack/issues/1460
Map.delete "DESTDIR" .
-- https://github.com/commercialhaskell/stack/issues/3444
Map.delete "GHCRTS"
-- | Get map of environment variables to set to change the GHC's encoding to UTF-8
getUtf8EnvVars
:: (HasProcessContext env, HasPlatform env, HasLogFunc env)
=> ActualCompiler
-> RIO env (Map Text Text)
getUtf8EnvVars compilerVer =
if getGhcVersion compilerVer >= mkVersion [7, 10, 3]
-- GHC_CHARENC supported by GHC >=7.10.3
then pure $ Map.singleton "GHC_CHARENC" "UTF-8"
else legacyLocale
where
legacyLocale = do
menv <- view processContextL
Platform _ os <- view platformL
if os == Cabal.Windows
then
-- On Windows, locale is controlled by the code page, so we don't set any environment
-- variables.
pure
Map.empty
else do
let checkedVars = map checkVar (Map.toList $ view envVarsL menv)
-- List of environment variables that will need to be updated to set UTF-8 (because
-- they currently do not specify UTF-8).
needChangeVars = concatMap fst checkedVars
-- Set of locale-related environment variables that have already have a value.
existingVarNames = Set.unions (map snd checkedVars)
-- True if a locale is already specified by one of the "global" locale variables.
hasAnyExisting =
any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]
if null needChangeVars && hasAnyExisting
then
-- If no variables need changes and at least one "global" variable is set, no
-- changes to environment need to be made.
pure
Map.empty
else do
-- Get a list of known locales by running @locale -a@.
elocales <- tryAny $ fmap fst $ proc "locale" ["-a"] readProcess_
let
-- Filter the list to only include locales with UTF-8 encoding.
utf8Locales =
case elocales of
Left _ -> []
Right locales ->
filter
isUtf8Locale
(T.lines $
T.decodeUtf8With
T.lenientDecode $
LBS.toStrict locales)
mfallback = getFallbackLocale utf8Locales
when
(isNothing mfallback)
(logWarn
"Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")
let
-- Get the new values of variables to adjust.
changes =
Map.unions $
map
(adjustedVarValue menv utf8Locales mfallback)
needChangeVars
-- Get the values of variables to add.
adds
| hasAnyExisting =
-- If we already have a "global" variable, then nothing needs
-- to be added.
Map.empty
| otherwise =
-- If we don't already have a "global" variable, then set LANG to the
-- fallback.
case mfallback of
Nothing -> Map.empty
Just fallback ->
Map.singleton "LANG" fallback
pure (Map.union changes adds)
-- Determines whether an environment variable is locale-related and, if so, whether it needs to
-- be adjusted.
checkVar
:: (Text, Text) -> ([Text], Set Text)
checkVar (k,v) =
if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k
then if isUtf8Locale v
then ([], Set.singleton k)
else ([k], Set.singleton k)
else ([], Set.empty)
-- Adjusted value of an existing locale variable. Looks for valid UTF-8 encodings with
-- same language /and/ territory, then with same language, and finally the first UTF-8 locale
-- returned by @locale -a@.
adjustedVarValue
:: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text
adjustedVarValue menv utf8Locales mfallback k =
case Map.lookup k (view envVarsL menv) of
Nothing -> Map.empty
Just v ->
case concatMap
(matchingLocales utf8Locales)
[ T.takeWhile (/= '.') v <> "."
, T.takeWhile (/= '_') v <> "_"] of
(v':_) -> Map.singleton k v'
[] ->
case mfallback of
Just fallback -> Map.singleton k fallback
Nothing -> Map.empty
-- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in
-- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale
-- -a@.
getFallbackLocale
:: [Text] -> Maybe Text
getFallbackLocale utf8Locales =
case concatMap (matchingLocales utf8Locales) fallbackPrefixes of
(v:_) -> Just v
[] ->
case utf8Locales of
[] -> Nothing
(v:_) -> Just v
-- Filter the list of locales for any with the given prefixes (case-insensitive).
matchingLocales
:: [Text] -> Text -> [Text]
matchingLocales utf8Locales prefix =
filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales
-- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?
isUtf8Locale locale =
any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes
-- Prefixes of fallback locales (case-insensitive)
fallbackPrefixes = ["C.", "en_US.", "en_"]
-- Suffixes of UTF-8 locales (case-insensitive)
utf8Suffixes = [".UTF-8", ".utf8"]
-- Binary Stack upgrades
-- | Information on a binary release of Stack
data StackReleaseInfo
= SRIGitHub !Value
-- ^ Metadata downloaded from GitHub releases about available binaries.
| SRIHaskellStackOrg !HaskellStackOrg
-- ^ Information on the latest available binary for the current platforms.
data HaskellStackOrg = HaskellStackOrg
{ hsoUrl :: !Text
, hsoVersion :: !Version
}
deriving Show
downloadStackReleaseInfo
:: (HasPlatform env, HasLogFunc env)
=> Maybe String -- GitHub org
-> Maybe String -- GitHub repo
-> Maybe String -- ^ optional version
-> RIO env StackReleaseInfo
downloadStackReleaseInfo Nothing Nothing Nothing = do
platform <- view platformL
-- Fallback list of URLs to try for upgrading.
let urls0 =
case platform of
Platform X86_64 Cabal.Linux ->
[ "https://get.haskellstack.org/upgrade/linux-x86_64-static.tar.gz"
, "https://get.haskellstack.org/upgrade/linux-x86_64.tar.gz"
]
Platform X86_64 Cabal.OSX ->
[ "https://get.haskellstack.org/upgrade/osx-x86_64.tar.gz"
]
Platform X86_64 Cabal.Windows ->
[ "https://get.haskellstack.org/upgrade/windows-x86_64.tar.gz"
]
_ -> []
-- Helper function: extract the version from a GitHub releases URL.
let extractVersion loc = do
version0 <-
case reverse $ splitOn "/" $ T.unpack loc of
_final:version0:_ -> Right version0
_ -> Left $ "Insufficient pieces in location: " ++ show loc
version1 <- maybe (Left "no leading v on version") Right $ stripPrefix "v" version0
maybe (Left $ "Invalid version: " ++ show version1) Right $ parseVersion version1
-- Try out different URLs. If we've exhausted all of them, fall back to GitHub.
loop [] = do
logDebug "Could not get binary from haskellstack.org, trying GitHub"
downloadStackReleaseInfoGitHub Nothing Nothing Nothing
-- Try the next URL
loop (url:urls) = do
-- Make a HEAD request without any redirects
req <- setRequestMethod "HEAD" <$> parseRequest (T.unpack url)
res <- httpLbs req { redirectCount = 0 }
-- Look for a redirect. We're looking for a standard GitHub releases
-- URL where we can extract version information from.
case getResponseHeader "location" res of
[] -> logDebug "No location header found, continuing" *> loop urls
-- Exactly one location header.
[locBS] ->
case decodeUtf8' locBS of
Left e -> logDebug ("Invalid UTF8: " <> displayShow (locBS, e)) *> loop urls
Right loc ->
case extractVersion loc of
Left s -> logDebug ("No version found: " <> displayShow (url, loc, s)) *> loop (loc:urls)
-- We found a valid URL, let's use it!
Right version -> do
let hso = HaskellStackOrg
{ hsoUrl = loc
, hsoVersion = version
}
logDebug $ "Downloading from haskellstack.org: " <> displayShow hso
pure $ SRIHaskellStackOrg hso
locs -> logDebug ("Multiple location headers found: " <> displayShow locs) *> loop urls
loop urls0
downloadStackReleaseInfo morg mrepo mver = downloadStackReleaseInfoGitHub morg mrepo mver
-- | Same as above, but always uses GitHub
downloadStackReleaseInfoGitHub
:: (MonadIO m, MonadThrow m)
=> Maybe String -- GitHub org
-> Maybe String -- GitHub repo
-> Maybe String -- ^ optional version
-> m StackReleaseInfo
downloadStackReleaseInfoGitHub morg mrepo mver = liftIO $ do
let org = fromMaybe "commercialhaskell" morg
repo = fromMaybe "stack" mrepo
let url = concat
[ "https://api.github.com/repos/"
, org
, "/"
, repo
, "/releases/"
, case mver of
Nothing -> "latest"
Just ver -> "tags/v" ++ ver
]
req <- parseRequest url
res <- httpJSON $ setGitHubHeaders req
let code = getResponseStatusCode res
if code >= 200 && code < 300
then pure $ SRIGitHub $ getResponseBody res
else throwIO $ StackReleaseInfoNotFound url
preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m [(Bool, String)]
preferredPlatforms = do
Platform arch' os' <- view platformL
(isWindows, os) <-
case os' of
Cabal.Linux -> pure (False, "linux")
Cabal.Windows -> pure (True, "windows")
Cabal.OSX -> pure (False, "osx")
Cabal.FreeBSD -> pure (False, "freebsd")
_ -> throwM $ BinaryUpgradeOnOSUnsupported os'
arch <-
case arch' of
I386 -> pure "i386"
X86_64 -> pure "x86_64"
Arm -> pure "arm"
_ -> throwM $ BinaryUpgradeOnArchUnsupported arch'
hasgmp4 <- pure False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
let suffixes
| hasgmp4 = ["-static", "-gmp4", ""]
| otherwise = ["-static", ""]
pure $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes
downloadStackExe
:: HasConfig env
=> [(Bool, String)] -- ^ acceptable platforms
-> StackReleaseInfo
-> Path Abs Dir -- ^ destination directory
-> Bool -- ^ perform PATH-aware checking, see #3232
-> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming
-> RIO env ()
downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do
(isWindows, archiveURL) <-
let loop [] = throwIO $ StackBinaryArchiveNotFound (map snd platforms0)
loop ((isWindows, p'):ps) = do
let p = T.pack p'
logInfo $ "Querying for archive location for platform: " <> fromString p'
case findArchive archiveInfo p of
Just x -> pure (isWindows, x)
Nothing -> loop ps
in loop platforms0
let (destFile, tmpFile)
| isWindows =
( destDir </> relFileStackDotExe
, destDir </> relFileStackDotTmpDotExe
)
| otherwise =
( destDir </> relFileStack
, destDir </> relFileStackDotTmp
)
logInfo $ "Downloading from: " <> display archiveURL
liftIO $ do
case () of
()
| ".tar.gz" `T.isSuffixOf` archiveURL ->
handleTarball tmpFile isWindows archiveURL
| ".zip" `T.isSuffixOf` archiveURL ->
throwIO StackBinaryArchiveZipUnsupportedBug
| otherwise -> throwIO $ StackBinaryArchiveUnsupported archiveURL
logInfo "Download complete, testing executable"
platform <- view platformL
-- We need to call getExecutablePath before we overwrite the
-- currently running binary: after that, Linux will append
-- (deleted) to the filename.
currExe <- liftIO getExecutablePath
liftIO $ do
setFileExecutable (toFilePath tmpFile)
testExe tmpFile
case platform of
Platform _ Cabal.Windows | FP.equalFilePath (toFilePath destFile) currExe -> do
old <- parseAbsFile (toFilePath destFile ++ ".old")
renameFile destFile old
renameFile tmpFile destFile
_ -> renameFile tmpFile destFile
destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
warnInstallSearchPathIssues destDir' ["stack"]
logInfo $ "New Stack executable available at " <> fromString (toFilePath destFile)
when checkPath $ performPathChecking destFile currExe
`catchAny` (logError . displayShow)
where
findArchive (SRIGitHub val) pattern = do
Object top <- pure val
Array assets <- KeyMap.lookup "assets" top
getFirst $ fold $ fmap (First . findMatch pattern') assets
where
pattern' = mconcat ["-", pattern, "."]
findMatch pattern'' (Object o) = do
String name <- KeyMap.lookup "name" o
guard $ not $ ".asc" `T.isSuffixOf` name
guard $ pattern'' `T.isInfixOf` name
String url <- KeyMap.lookup "browser_download_url" o
Just url
findMatch _ _ = Nothing
findArchive (SRIHaskellStackOrg hso) _ = pure $ hsoUrl hso
handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()
handleTarball tmpFile isWindows url = do
req <- fmap setGitHubHeaders $ parseUrlThrow $ T.unpack url
withResponse req $ \res -> do
entries <- fmap (Tar.read . LBS.fromChunks)
$ lazyConsume
$ getResponseBody res .| ungzip
let loop Tar.Done = throwIO $ StackBinaryNotInArchive exeName url
loop (Tar.Fail e) = throwM e
loop (Tar.Next e es) =
case FP.splitPath (Tar.entryPath e) of
-- Ignore the first component, see: https://github.com/commercialhaskell/stack/issues/5288
[_ignored, name] | name == exeName -> do
case Tar.entryContent e of
Tar.NormalFile lbs _ -> do
ensureDir destDir
LBS.writeFile (toFilePath tmpFile) lbs
_ -> throwIO $ FileTypeInArchiveInvalid e url
_ -> loop es
loop entries
where
exeName
| isWindows = "stack.exe"
| otherwise = "stack"
-- | Ensure that the Stack executable download is in the same location
-- as the currently running executable. See:
-- https://github.com/commercialhaskell/stack/issues/3232
performPathChecking
:: HasConfig env
=> Path Abs File -- ^ location of the newly downloaded file
-> String -- ^ currently running executable
-> RIO env ()
performPathChecking newFile executablePath = do
executablePath' <- parseAbsFile executablePath
unless (toFilePath newFile == executablePath) $ do
logInfo $ "Also copying Stack executable to " <> fromString executablePath
tmpFile <- parseAbsFile $ executablePath ++ ".tmp"
eres <- tryIO $ do
liftIO $ copyFile newFile tmpFile
setFileExecutable (toFilePath tmpFile)
liftIO $ renameFile tmpFile executablePath'
logInfo "Stack executable copied successfully!"
case eres of
Right () -> pure ()
Left e
| isPermissionError e -> do
logWarn $ "Permission error when trying to copy: " <> displayShow e
logWarn "Should I try to perform the file copy using sudo? This may fail"
toSudo <- promptBool "Try using sudo? (y/n) "
when toSudo $ do
let run cmd args = do
ec <- proc cmd args runProcess
when (ec /= ExitSuccess) $
throwIO $ ProcessExited ec cmd args
commands =
[ ("sudo",
[ "cp"
, toFilePath newFile
, toFilePath tmpFile
])
, ("sudo",
[ "mv"
, toFilePath tmpFile
, executablePath
])
]
logInfo "Going to run the following commands:"
logInfo ""
forM_ commands $ \(cmd, args) ->
logInfo $ "- " <> mconcat (intersperse " " (fromString <$> (cmd:args)))
mapM_ (uncurry run) commands
logInfo ""
logInfo "sudo file copy worked!"
| otherwise -> throwM e
getDownloadVersion :: StackReleaseInfo -> Maybe Version
getDownloadVersion (SRIGitHub val) = do
Object o <- Just val
String rawName <- KeyMap.lookup "name" o
-- drop the "v" at the beginning of the name
parseVersion $ T.unpack (T.drop 1 rawName)
getDownloadVersion (SRIHaskellStackOrg hso) = Just $ hsoVersion hso