{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE LambdaCase #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE PackageImports #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE MultiWayIf #-}

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

import Control.Applicative (empty)

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

import Pantry.Internal.AesonExtended

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.Foldable (maximumBy)

import qualified Data.HashMap.Strict as HashMap

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 qualified Data.Yaml as Yaml

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

import qualified Distribution.System as Cabal

import Distribution.Text (simpleParse)

import Distribution.Types.PackageName (mkPackageName)

import Distribution.Version (mkVersion)

import Network.HTTP.StackClient (CheckHexDigest (..), HashCheck (..),

getResponseBody, getResponseStatusCode, httpLbs, httpJSON,

mkDownloadRequest, parseRequest, parseUrlThrow, setGithubHeaders,

setHashChecks, setLengthCheck, verifiedDownloadWithProgress, withResponse)

import Path hiding (fileExtension)

import Path.CheckInstall (warnInstallSearchPathIssues)

import Path.Extended (fileExtension)

import Path.Extra (toFilePathNoTrailingSep)

import Path.IO hiding (findExecutable, withSystemTempDir)

import qualified Pantry

import qualified RIO

import RIO.List

import RIO.PrettyPrint

import RIO.Process

import Stack.Build.Haddock (shouldHaddockDeps)

import Stack.Build.Source (loadSourceMap, hashSourceMapData)

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

import Stack.Constants

import Stack.Constants.Config (distRelativeDir)

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

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

import Stack.SourceMap

import Stack.Setup.Installed

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)

import Data.List.Split (splitOn)

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

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

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 "

, T.unpack $ utf8BuilderToText $ RIO.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)))

]

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

show (InvalidGhcAt compiler e) =

"Found an invalid compiler at " ++ show (toFilePath compiler) ++ ": " ++ displayException e

-- | 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 (return . 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 return $ augmentPath (toFilePath <$> mkDirs False) mpath

localsPath <- either throwM return $ 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 -> 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)

-- Make sure that any .ghc.environment files

-- are ignored, since we're settting 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', ())

return eo

envOverride <- liftIO $ getProcessContext' minimalEnvSettings

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

return $

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

actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts

didWarn <- warnUnsupportedCompiler $ getGhcVersion actual

getSetupInfo' <- memoizeRef getSetupInfo

(cp, ghcPaths) <- ensureCompiler sopts getSetupInfo'

warnUnsupportedCompilerCabal cp didWarn

mmsys2Tool <- ensureMsys sopts getSetupInfo'

paths <-

case mmsys2Tool of

Nothing -> pure ghcPaths

Just msys2Tool -> do

msys2Paths <- extraDirs msys2Tool

pure $ ghcPaths <> msys2Paths

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 [8, 11] -> do

logWarn $

"Stack has not been tested with GHC versions above 8.10, 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, 3] ->

logWarn $

"Stack has not been tested with Cabal versions above 3.2, 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 -> return (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 -> return x

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

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

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

| otherwise -> do

logWarn "Continuing despite missing tool: msys2"

return Nothing

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

return (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_):_ -> return (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. (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

Platform expectedArch _ <- view platformL

let canUseCompiler cp

| soptsSkipGhcCheck sopts = pure cp

| not $ isWanted $ cpCompilerVersion cp = throwString "Not the compiler version we want"

| cpArch cp /= expectedArch = throwString "Not the architecture we want"

| 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

then do

logDebug "Getting system compiler version"

runConduit $

sourceSystemCompilers wanted .|

concatMapMC checkCompiler .|

await

else return Nothing

case mcp of

Nothing -> ensureSandboxedCompiler sopts getSetupInfo'

Just cp -> do

let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] }

pure (cp, paths)

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 return

$ 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

let loop [] = do

logError $ "Looked for sandboxed compiler named one of: " <> displayShow names

logError $ "Could not find it on the paths " <> displayShow (edBins paths)

throwString "Could not find sandboxed compiler"

loop (x:xs) = do

res <- findExecutable x

case res of

Left _ -> loop xs

Right y -> parseAbsFile y

compiler <- withProcessContext menv $ loop names

when (soptsSanityCheck sopts) $ sanityCheck 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 [] = throwString $ "Could not find any of: " <> show 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 -> throwString $ "GHC info is not valid UTF-8: " ++ show e

Right info -> pure info

infoPairs :: [(String, String)] <-

case readMaybe $ T.unpack infotext of

Nothing -> throwString "GHC info does not parse as a list of pairs"

Just infoPairs -> pure infoPairs

let infoMap = Map.fromList infoPairs

eglobaldb <- tryAny $

case Map.lookup "Global Package DB" infoMap of

Nothing -> throwString "Key 'Global Package DB' not found in GHC info"

Just db -> parseAbsDir db

arch <-

case Map.lookup "Target platform" infoMap of

Nothing -> throwString "Key 'Target platform' not found in GHC info"

Just targetPlatform ->

case simpleParse $ takeWhile (/= '-') targetPlatform of

Nothing -> throwString $ "Invalid target platform in GHC info: " ++ show 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 -> throwString $ "Cabal library not found in global package database for " ++ toFilePath compiler

Just dp -> pure $ pkgVersion $ dpPackageIdent dp

return 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 return (compilerTool,CompilerBuildStandard)

else do

let repo = Repo

{ repoCommit = commitId

, repoUrl = url

, repoType = RepoGit

, repoSubdir = mempty

}

-- clone the repository and execute the given commands

Pantry.withRepo repo $ do

-- withRepo is guaranteed to set workingDirL, so let's get it

mcwd <- traverse parseAbsDir =<< view workingDirL

let cwd = fromMaybe (error "Invalid working directory") 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"

]

hadrianCmd

| osIsWindows = hadrianCmdWindows

| otherwise = hadrianCmdPosix

logSticky $ "Building GHC from source with `"

<> RIO.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 (cwd </> hadrianCmd)) hadrianArgs runProcess_

-- find the bindist and install it

bindistPath <- parseRelDir "_build/bindist"

(_,files) <- listDir (cwd </> bindistPath)

let

isBindist p = do

extension <- fileExtension (filename p)

return $ "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 Nothing

| otherwise = installGHCPosix Nothing ghcdlinfo

si <- runMemoized getSetupInfo'

_ <- downloadAndInstallTool

(configLocalPrograms config)

dlinfo

compilerTool

(installer si)

return (compilerTool, CompilerBuildStandard)

_ -> do

forM_ files (logDebug . fromString . (" - " ++) . toFilePath)

error "Can't find hadrian generated bindist"

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

return True

| osIsWindows =

-- Cannot parse /usr/lib on Windows

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

>> return False

(path:_) -> logDebug ("Found shared library " <> libD

<> " in " <> fromString (Path.toFilePath path))

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

return 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