{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10

{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE LambdaCase #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE PackageImports #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE CPP #-}

module Stack.Setup

( setupEnv

, ensureCompiler

, ensureDockerStackExe

, getSystemCompiler

, getCabalInstallVersion

, SetupOpts (..)

, defaultSetupInfoYaml

, removeHaskellEnvVars

-- * Stack binary download

, StackReleaseInfo

, getDownloadVersion

, stackVersion

, preferredPlatforms

, downloadStackReleaseInfo

, downloadStackExe

) where

import qualified Codec.Archive.Tar as Tar

import Control.Applicative (empty)

import Control.Monad.State (get, put, modify)

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

import Data.Aeson.Extended

import qualified Data.ByteString as S

import qualified Data.ByteString.Lazy as LBS

import qualified Data.ByteString.Lazy.Char8 as BL8

import Data.Char (isSpace)

import Data.Conduit (await, yield, awaitForever)

import qualified Data.Conduit.Binary as CB

import Data.Conduit.Lazy (lazyConsume)

import Data.Conduit.Lift (evalStateC)

import qualified Data.Conduit.List as CL

import Data.Conduit.Process.Typed (eceStderr)

import Data.Conduit.Zlib (ungzip)

import Data.Foldable (maximumBy)

import qualified Data.HashMap.Strict as HashMap

import Data.IORef.RunOnce (runOnce)

import Data.List hiding (concat, elem, maximumBy, any)

import qualified Data.Map as Map

import qualified Data.Set as Set

import qualified Data.Text as T

import qualified Data.Text.Encoding as T

import qualified Data.Text.Encoding.Error as T

import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)

import qualified Data.Yaml as Yaml

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

import qualified Distribution.System as Cabal

import Distribution.Text (simpleParse)

import Lens.Micro (set)

import Network.HTTP.Simple (getResponseBody, getResponseStatusCode)

import Network.HTTP.Download

import Path

import Path.CheckInstall (warnInstallSearchPathIssues)

import Path.Extra (toFilePathNoTrailingSep)

import Path.IO hiding (findExecutable, withSystemTempDir)

import Prelude (getLine, putStr, putStrLn, until)

import qualified RIO

import Stack.Build (build)

import Stack.Config (loadConfig)

import Stack.Constants (stackProgName)

import Stack.Constants.Config (distRelativeDir)

import Stack.Fetch

import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)

import Stack.Prelude hiding (Display (..))

import Stack.PrettyPrint

import Stack.Setup.Installed

import Stack.Snapshot (loadSnapshot)

import Stack.Types.Build

import Stack.Types.Compiler

import Stack.Types.CompilerBuild

import Stack.Types.Config

import Stack.Types.Docker

import Stack.Types.PackageIdentifier

import Stack.Types.PackageName

import Stack.Types.Runner

import Stack.Types.Version

import qualified System.Directory as D

import System.Environment (getExecutablePath, lookupEnv)

import System.Exit (ExitCode (..), exitFailure)

import System.IO (stdout)

import System.IO.Error (isPermissionError)

import System.FilePath (searchPathSeparator)

import qualified System.FilePath as FP

import RIO.Process

import Text.Printf (printf)

#if !WINDOWS

import Bindings.Uname (uname, release)

import Data.List.Split (splitOn)

import Foreign.C (throwErrnoIfMinus1_, peekCString)

import Foreign.Marshal (alloca)

import System.Posix.Files (setFileMode)

#endif

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

defaultSetupInfoYaml :: String

defaultSetupInfoYaml =

"https://raw.githubusercontent.com/fpco/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 :: !(CompilerVersion 'CVWanted)

, 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

, soptsUpgradeCabal :: !(Maybe UpgradeTo)

-- ^ Upgrade the global Cabal library in the database to the newest

-- version. Only works reliably with a stack-managed installation.

, soptsResolveMissingGHC :: !(Maybe Text)

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

, soptsSetupInfoYaml :: !FilePath

-- ^ Location of the main stack-setup.yaml file

, soptsGHCBindistURL :: !(Maybe String)

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

, soptsGHCJSBootOpts :: [String]

-- ^ Additional ghcjs-boot options, the default is "--clean"

}

deriving Show

data SetupException = UnsupportedSetupCombo OS Arch

| MissingDependencies [String]

| UnknownCompilerVersion (Set.Set Text) (CompilerVersion 'CVWanted) (Set.Set (CompilerVersion 'CVActual))

| UnknownOSKey Text

| GHCSanityCheckCompileFailed SomeException (Path Abs File)

| WantedMustBeGHC

| RequireCustomGHCVariant

| ProblemWhileDecompressing (Path Abs File)

| SetupInfoMissingSevenz

| GHCJSRequiresStandardVariant

| GHCJSNotBooted

| DockerStackExeNotFound Version Text

| UnsupportedSetupConfiguration

deriving Typeable

instance Exception SetupException

instance Show SetupException where

show (UnsupportedSetupCombo os arch) = concat

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

, show (os, arch)

, ", please install manually"

]

show (MissingDependencies tools) =

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

intercalate ", " tools

show (UnknownCompilerVersion oskeys wanted known) = concat

[ "No setup information found for "

, compilerVersionString 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)))

]

show (UnknownOSKey oskey) =

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

T.unpack oskey

show (GHCSanityCheckCompileFailed e ghc) = concat

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

, show e

]

show WantedMustBeGHC =

"The wanted compiler must be GHC"

show RequireCustomGHCVariant =

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

show (ProblemWhileDecompressing archive) =

"Problem while decompressing " ++ toFilePath archive

show SetupInfoMissingSevenz =

"SetupInfo missing Sevenz EXE/DLL"

show GHCJSRequiresStandardVariant =

"stack does not yet support using --ghc-variant with GHCJS"

show GHCJSNotBooted =

"GHCJS does not yet have its boot packages installed. Use \"stack setup\" to attempt to run ghcjs-boot."

show (DockerStackExeNotFound stackVersion' osKey) = concat

[ stackProgName

, "-"

, versionString stackVersion'

, " executable not found for "

, T.unpack osKey

, "\nUse the '"

, T.unpack dockerStackExeArgName

, "' option to specify a location"]

show UnsupportedSetupConfiguration =

"I don't know how to install GHC on your system configuration, please install manually"

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

setupEnv :: (HasBuildConfig env, HasGHCVariant env)

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

-> RIO env EnvConfig

setupEnv mResolveMissingGHC = do

config <- view configL

bconfig <- view buildConfigL

let stackYaml = bcStackYaml bconfig

platform <- view platformL

wcVersion <- view wantedCompilerVersionL

wc <- view $ wantedCompilerVersionL.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

, soptsUpgradeCabal = Nothing

, soptsResolveMissingGHC = mResolveMissingGHC

, soptsSetupInfoYaml = defaultSetupInfoYaml

, soptsGHCBindistURL = Nothing

, soptsGHCJSBootOpts = ["--clean"]

}

(mghcBin, compilerBuild, _) <- ensureCompiler sopts

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

-- is being used

menv0 <- view processContextL

env <- either throwM (return . removeHaskellEnvVars)

$ augmentPathMap

(map toFilePath $ maybe [] edBins mghcBin)

(view envVarsL menv0)

menv <- mkProcessContext env

(compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,)

<$> Concurrently (getCompilerVersion wc)

<*> Concurrently (getCabalPkgVer wc)

<*> Concurrently (getGlobalDB wc)

logDebug "Resolving package entries"

packagesRef <- liftIO $ newIORef Nothing

bc <- view buildConfigL

-- 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 in loadSnapshot.

let bcPath :: BuildConfig

bcPath = set processContextL menv bc

ls <- runRIO bcPath $ loadSnapshot

(Just compilerVer)

(view projectRootL bc)

(bcSnapshotDef bc)

let envConfig0 = EnvConfig

{ envConfigBuildConfig = bc

, envConfigCabalVersion = cabalVer

, envConfigCompilerVersion = compilerVer

, envConfigCompilerBuild = compilerBuild

, envConfigPackagesRef = packagesRef

, envConfigLoadedSnapshot = ls

}

-- extra installation bin directories

mkDirs <- runReaderT extraBinDirs envConfig0

let mpath = Map.lookup "PATH" env

depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath

localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath

deps <- runReaderT packageDatabaseDeps envConfig0

withProcessContext menv $ createDatabase wc deps

localdb <- runReaderT packageDatabaseLocal envConfig0

withProcessContext menv $ createDatabase wc localdb

extras <- runReaderT packageDatabaseExtra envConfig0

let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb

distDir <- runReaderT distRelativeDir envConfig0

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 -> return 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/fpco/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) env

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

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

return eo

envOverride <- liftIO $ getProcessContext' minimalEnvSettings

return EnvConfig

{ envConfigBuildConfig = bconfig

{ bcConfig = maybe id addIncludeLib mghcBin

$ set processContextL envOverride

(view configL bconfig)

{ configProcessContextSettings = getProcessContext'

}

}

, envConfigCabalVersion = cabalVer

, envConfigCompilerVersion = compilerVer

, envConfigCompilerBuild = compilerBuild

, envConfigPackagesRef = envConfigPackagesRef envConfig0

, envConfigLoadedSnapshot = ls

}

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

addIncludeLib :: ExtraDirs -> Config -> Config

addIncludeLib (ExtraDirs _bins includes libs) config = config

{ configExtraIncludeDirs = Set.union

(configExtraIncludeDirs config)

(Set.fromList (map toFilePathNoTrailingSep includes))

, configExtraLibDirs = Set.union

(configExtraLibDirs config)

(Set.fromList (map toFilePathNoTrailingSep libs))

}

-- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary

ensureCompiler :: (HasConfig env, HasGHCVariant env)

=> SetupOpts

-> RIO env (Maybe ExtraDirs, CompilerBuild, Bool)

ensureCompiler sopts = do

let wc = whichCompiler (soptsWantedCompiler sopts)

when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do

logWarn "Stack will almost certainly fail with GHC below version 7.8"

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

msystem <-

if soptsUseSystem sopts

then do

logDebug "Getting system compiler version"

getSystemCompiler wc

else return Nothing

Platform expectedArch _ <- view platformL

let canUseCompiler compilerVersion arch

| soptsSkipGhcCheck sopts = True

| otherwise = isWanted compilerVersion && arch == expectedArch

isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)

needLocal = not (any (uncurry canUseCompiler) msystem)

getSetupInfo' <- runOnce (getSetupInfo (soptsSetupInfoYaml sopts))

let getMmsys2Tool = 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 -> return (Just tool)

Nothing

| soptsInstallIfMissing sopts -> do

si <- getSetupInfo'

osKey <- getOSKey platform

config <- view configL

VersionedDownloadInfo version info <-

case Map.lookup osKey $ siMsys2 si of

Just x -> return x

Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey

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

Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey)

| otherwise -> do

logWarn "Continuing despite missing tool: msys2"

return Nothing

_ -> return Nothing

-- If we need to install a GHC or MSYS, try to do so

-- Return the additional directory paths of GHC & MSYS.

(mtools, compilerBuild) <- if needLocal

then do

-- Install GHC

ghcVariant <- view ghcVariantL

config <- view configL

let localPrograms = configLocalPrograms config

installed <- listInstalled localPrograms

possibleCompilers <-

case wc of

Ghc -> do

ghcBuilds <- getGhcBuilds

forM ghcBuilds $ \ghcBuild -> do

ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)

return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild)

Ghcjs -> return [(getInstalledGhcjs installed isWanted, CompilerBuildStandard)]

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

(compilerTool, compilerBuild) <- case existingCompilers of

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

[]

| soptsInstallIfMissing sopts -> do

si <- getSetupInfo'

downloadAndInstallPossibleCompilers

(map snd possibleCompilers)

si

(soptsWantedCompiler sopts)

(soptsCompilerCheck sopts)

(soptsGHCBindistURL sopts)

| otherwise -> do

recommendSystemGhc <-

if soptsUseSystem sopts

then return False

else do

msystemGhc <- getSystemCompiler wc

return (any (uncurry canUseCompiler) msystemGhc)

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

| recommendSystemGhc

]))

(soptsResolveMissingGHC sopts)

throwM $ CompilerVersionMismatch

msystem

(soptsWantedCompiler sopts, expectedArch)

ghcVariant

(case possibleCompilers of

[] -> CompilerBuildStandard

(_, compilerBuild):_ -> compilerBuild)

(soptsCompilerCheck sopts)

(soptsStackYaml sopts)

suggestion

-- Install msys2 on windows, if necessary

mmsys2Tool <- getMmsys2Tool

return (Just (Just compilerTool, mmsys2Tool), compilerBuild)

-- Have the right ghc, may still need msys

else do

mmsys2Tool <- getMmsys2Tool

return (Just (Nothing, mmsys2Tool), CompilerBuildStandard)

mpaths <- case mtools of

Nothing -> return Nothing

Just (compilerTool, mmsys2Tool) -> do

-- Add GHC's and MSYS's paths to the config.

let idents = catMaybes [compilerTool, mmsys2Tool]

paths <- mapM extraDirs idents

return $ Just $ mconcat paths

menv <-

case mpaths of

Nothing -> view processContextL

Just ed -> do

menv0 <- view processContextL

m <- either throwM return

$ augmentPathMap (toFilePath <$> edBins ed) (view envVarsL menv0)

mkProcessContext (removeHaskellEnvVars m)

forM_ (soptsUpgradeCabal sopts) $ \version -> do

unless needLocal $ do

logWarn "Trying to change a Cabal library on a GHC not installed by stack."

logWarn "This may fail, caveat emptor!"

withProcessContext menv $ upgradeCabal wc version

case mtools of

Just (Just (ToolGhcjs cv), _) ->

withProcessContext menv

$ ensureGhcjsBooted cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts)

_ -> return ()

when (soptsSanityCheck sopts) $ withProcessContext menv $ sanityCheck wc

return (mpaths, compilerBuild, needLocal)

-- | 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 -> return [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 . readProcessStdout_

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

return True

| otherwise = do

#ifdef WINDOWS

-- (mkAbsDir "/usr/lib") fails to compile on Windows, thus the CPP

return False

#else

-- This is a workaround for the fact that libtinfo.so.6 doesn't appear in

-- the 'ldconfig -p' output on Arch 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 case.

e <- doesFileExist ($(mkAbsDir "/usr/lib") </> lib)

if e

then logDebug ("Found shared library " <> libD <> " in /usr/lib")

else logDebug ("Did not find shared library " <> libD)

return e

#endif

where

libT = T.pack (toFilePath lib)

libD = fromString (toFilePath lib)

hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5")

hastinfo6 <- checkLib $(mkRelFile "libtinfo.so.6")

hasncurses6 <- checkLib $(mkRelFile "libncursesw.so.6")

hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10")

hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3")

let libComponents = concat

[ [["tinfo6"] | hastinfo6 && hasgmp5]

, [[] | hastinfo5 && hasgmp5]

, [["ncurses6"] | hasncurses6 && hasgmp5 ]

, [["gmp4"] | hasgmp4 ]

]

useBuilds $ map

(\c -> case c of

[] -> CompilerBuildStandard

_ -> CompilerBuildSpecialized (intercalate "-" c))

libComponents

#if !WINDOWS

Platform _ Cabal.OpenBSD -> do

releaseStr <- mungeRelease <$> sysRelease

useBuilds [CompilerBuildSpecialized releaseStr]

#endif

_ -> useBuilds [CompilerBuildStandard]

useBuilds builds = do

logDebug $

"Potential GHC builds: " <>

mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))

return builds

#if !WINDOWS

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

return "") .

liftIO .

alloca $ \ ptr ->

do throwErrnoIfMinus1_ "uname" $ uname ptr

peekCString $ release ptr

#endif

-- | 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 </> $(mkRelFile "stack")

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 $ return ())

return stackExePath

-- | Install the newest version or a specific version of Cabal globally

upgradeCabal :: (HasConfig env, HasGHCVariant env)

=> WhichCompiler

-> UpgradeTo

-> RIO env ()

upgradeCabal wc upgradeTo = do

logInfo "Manipulating the global Cabal is only for debugging purposes"

let name = $(mkPackageName "Cabal")

rmap <- resolvePackages Nothing mempty (Set.singleton name)

installed <- getCabalPkgVer wc

case upgradeTo of

Specific wantedVersion -> do

if installed /= wantedVersion then

doCabalInstall wc installed wantedVersion

else

logInfo $

"No install necessary. Cabal " <>

RIO.display installed <>

" is already installed"

Latest -> case map rpIdent rmap of

[] -> throwString "No Cabal library found in index, cannot upgrade"

[PackageIdentifier name' latestVersion] | name == name' -> do

if installed < latestVersion then

doCabalInstall wc installed latestVersion

else

logInfo $

"No upgrade necessary: Cabal-" <>

RIO.display latestVersion <>

" is the same or newer than latest hackage version " <>

RIO.display installed

x -> error $ "Unexpected results for resolvePackages: " ++ show x

-- Configure and run the necessary commands for a cabal install

doCabalInstall :: (HasConfig env, HasGHCVariant env)

=> WhichCompiler

-> Version

-> Version

-> RIO env ()

doCabalInstall wc installed wantedVersion = do

withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do

logInfo $

"Installing Cabal-" <>

RIO.display wantedVersion <>

" to replace " <>

RIO.display installed

let name = $(mkPackageName "Cabal")

ident = PackageIdentifier name wantedVersion

m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest]

compilerPath <- findExecutable (compilerExeName wc)

>>= either throwM parseAbsFile

versionDir <- parseRelDir $ versionString wantedVersion

let installRoot = toFilePath $ parent (parent compilerPath)

</> $(mkRelDir "new-cabal")

</> versionDir

dir <- case Map.lookup ident m of

Nothing -> error "upgradeCabal: Invariant violated, dir missing"

Just dir -> return dir

withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) ["Setup.hs"] runProcess_

platform <- view platformL

let setupExe = toFilePath $ dir </> case platform of

Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe")

_ -> $(mkRelFile "Setup")

dirArgument name' = concat [ "--"

, name'

, "dir="

, installRoot FP.</> name'

]

args = "configure" : map dirArgument (words "lib bin data doc")

withWorkingDir (toFilePath dir) $ do

proc setupExe args runProcess_

proc setupExe ["build"] runProcess_

proc setupExe ["install"] runProcess_

logInfo "New Cabal library installed"

-- | Get the version of the system compiler, if available

getSystemCompiler

:: (HasProcessContext env, HasLogFunc env)

=> WhichCompiler

-> RIO env (Maybe (CompilerVersion 'CVActual, Arch))

getSystemCompiler wc = do

let exeName = case wc of

Ghc -> "ghc"

Ghcjs -> "ghcjs"

exists <- doesExecutableExist exeName

if exists

then do

eres <- proc exeName ["--info"] $ tryAny . readProcessStdout_

let minfo = do

Right lbs <- Just eres

pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)]

version <- lookup "Project version" pairs_ >>= parseVersionFromString

arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-')

return (version, arch)

case (wc, minfo) of

(Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch))

(Ghcjs, Just (_, arch)) -> do

eversion <- tryAny $ getCompilerVersion Ghcjs

case eversion of

Left _ -> return Nothing

Right version -> return (Just (version, arch))

(_, Nothing) -> return Nothing

else return Nothing

-- | Download the most recent SetupInfo

getSetupInfo :: HasConfig env => String -> RIO env SetupInfo

getSetupInfo stackSetupYaml = do

config <- view configL

setupInfos <-

mapM

loadSetupInfo

(SetupInfoFileOrURL stackSetupYaml :

configSetupInfoLocations config)

return (mconcat setupInfos)

where

loadSetupInfo (SetupInfoInline si) = return si

loadSetupInfo (SetupInfoFileOrURL 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 return (Yaml.decodeEither' bs)

when (urlOrFile /= defaultSetupInfoYaml) $

logJSONWarnings urlOrFile warnings

return si

getInstalledTool :: [Tool] -- ^ already installed

-> PackageName -- ^ package to find

-> (Version -> Bool) -- ^ which versions are acceptable

-> Maybe Tool

getInstalledTool installed name goodVersion =

if null available

then Nothing

else Just $ Tool $ maximumBy (comparing packageIdentifierVersion) available

where

available = mapMaybe goodPackage installed

goodPackage (Tool pi') =

if packageIdentifierName pi' == name &&

goodVersion (packageIdentifierVersion pi')

then Just pi'

else Nothing

goodPackage _ = Nothing

getInstalledGhcjs :: [Tool]

-> (CompilerVersion 'CVActual -> Bool)

-> Maybe Tool

getInstalledGhcjs installed goodVersion =

if null available

then Nothing

else Just $ ToolGhcjs $ maximum available

where

available = mapMaybe goodPackage installed

goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing

goodPackage _ = Nothing

downloadAndInstallTool :: HasRunner env

=> Path Abs Dir

-> SetupInfo

-> DownloadInfo

-> Tool

-> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())

-> RIO env Tool

downloadAndInstallTool programsDir si 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 si file at tempDir dir

markInstalled programsDir tool

liftIO $ ignoringAbsence (removeDirRecur tempDir)

return tool

downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env)

=> CompilerBuild

-> SetupInfo

-> CompilerVersion 'CVWanted

-> VersionCheck

-> Maybe String

-> RIO env Tool

downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do

ghcVariant <- view ghcVariantL

(selectedVersion, downloadInfo) <- case mbindistURL of

Just bindistURL -> do

case ghcVariant of

GHCCustom _ -> return ()

_ -> throwM RequireCustomGHCVariant

case wanted of

GhcVersion version ->

return (version, GHCDownloadInfo mempty mempty DownloadInfo

{ downloadInfoUrl = T.pack bindistURL

, downloadInfoContentLength = Nothing

, downloadInfoSha1 = Nothing

, downloadInfoSha256 = Nothing

})

_ ->

throwM WantedMustBeGHC

_ -> do

ghcKey <- getGhcKey ghcBuild

case Map.lookup ghcKey $ siGHCs si of

Nothing -> throwM $ UnknownOSKey ghcKey

Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_

config <- view configL

let installer =

case configPlatform config of

Platform _ Cabal.Windows -> installGHCWindows selectedVersion

_ -> installGHCPosix selectedVersion 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 <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)

let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion

downloadAndInstallTool (configLocalPrograms config) si (gdiDownloadInfo downloadInfo) tool installer

downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do

config <- view configL

ghcVariant <- view ghcVariantL

case (ghcVariant, compilerBuild) of

(GHCStandard, CompilerBuildStandard) -> return ()

_ -> throwM GHCJSRequiresStandardVariant

(selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of

Nothing -> throwM $ UnknownOSKey "source"

Just pairs_ -> getWantedCompilerInfo "source" versionCheck wanted id pairs_

logInfo "Preparing to install GHCJS to an isolated location."

logInfo "This will not interfere with any system-level installation."

let tool = ToolGhcjs selectedVersion

downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installGHCJS

getWantedCompilerInfo :: (Ord k, MonadThrow m)

=> Text

-> VersionCheck

-> CompilerVersion 'CVWanted

-> (k -> CompilerVersion 'CVActual)

-> Map k a

-> m (k, a)

getWantedCompilerInfo key versionCheck wanted toCV pairs_ =

case mpair of

Just pair -> return 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, HasConfig env)

=> [CompilerBuild]

-> SetupInfo

-> CompilerVersion 'CVWanted

-> 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 non-existent,

-- 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 -> return (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

return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)

getOSKey :: (MonadThrow m)

=> Platform -> m Text

getOSKey platform =

case platform of

Platform I386 Cabal.Linux -> return "linux32"

Platform X86_64 Cabal.Linux -> return "linux64"

Platform I386 Cabal.OSX -> return "macosx"

Platform X86_64 Cabal.OSX -> return "macosx"

Platform I386 Cabal.FreeBSD -> return "freebsd32"

Platform X86_64 Cabal.FreeBSD -> return "freebsd64"

Platform I386 Cabal.OpenBSD -> return "openbsd32"

Platform X86_64 Cabal.OpenBSD -> return "openbsd64"

Platform I386 Cabal.Windows -> return "windows32"

Platform X86_64 Cabal.Windows -> return "windows64"

Platform Arm Cabal.Linux -> return "linux-armv7"

Platform (OtherArch "aarch64") Cabal.Linux -> return "linux-aarch64"