{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE PackageImports #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE LambdaCase #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE TupleSections #-}

module Stack.Setup

( setupEnv

, ensureCompiler

, ensureDockerStackExe

, SetupOpts (..)

, defaultStackSetupYaml

) where

import Control.Applicative

import Control.Exception.Enclosed (catchIO, tryAny)

import Control.Monad (liftM, when, join, void, unless)

import Control.Monad.Catch

import Control.Monad.IO.Class (MonadIO, liftIO)

import Control.Monad.Logger

import Control.Monad.Reader (MonadReader, ReaderT (..), asks)

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

import Control.Monad.Trans.Control

import "cryptohash" Crypto.Hash (SHA1(SHA1))

import Data.Aeson.Extended

import qualified Data.ByteString as S

import qualified Data.ByteString.Char8 as S8

import qualified Data.ByteString.Lazy as LBS

import Data.Char (isSpace)

import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)

import qualified Data.Conduit.Binary as CB

import Data.Conduit.Lift (evalStateC)

import qualified Data.Conduit.List as CL

import Data.Either

import Data.Foldable hiding (concatMap, or, maximum)

import Data.IORef

import Data.IORef.RunOnce (runOnce)

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

import Data.Map (Map)

import qualified Data.Map as Map

import Data.Maybe

import Data.Monoid

import Data.Ord (comparing)

import Data.Set (Set)

import qualified Data.Set as Set

import Data.Text (Text)

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 Data.Typeable (Typeable)

import qualified Data.Yaml as Yaml

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

import qualified Distribution.System as Cabal

import Distribution.Text (simpleParse)

import Language.Haskell.TH as TH

import Network.HTTP.Client.Conduit

import Network.HTTP.Download.Verified

import Path

import Path.Extra (toFilePathNoTrailingSep)

import Path.IO

import qualified Paths_stack as Meta

import Prelude hiding (concat, elem, any) -- Fix AMP warning

import Safe (readMay)

import Stack.Build (build)

import Stack.Config (resolvePackageEntry, loadConfig)

import Stack.Constants (distRelativeDir, stackProgName)

import Stack.Exec (defaultEnvSettings)

import Stack.Fetch

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

import Stack.Setup.Installed

import Stack.Types

import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel)

import Stack.Types.StackT

import qualified System.Directory as D

import System.Environment (getExecutablePath)

import System.Exit (ExitCode (ExitSuccess))

import System.FilePath (searchPathSeparator)

import qualified System.FilePath as FP

import System.Process (rawSystem)

import System.Process.Read

import System.Process.Run (runCmd, Cmd(..))

import Text.Printf (printf)

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

defaultStackSetupYaml :: String

defaultStackSetupYaml =

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

data SetupOpts = SetupOpts

{ soptsInstallIfMissing :: !Bool

, soptsUseSystem :: !Bool

, soptsWantedCompiler :: !CompilerVersion

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

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

, soptsStackSetupYaml :: !FilePath

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

, soptsGHCBindistURL :: !(Maybe String)

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

}

deriving Show

data SetupException = UnsupportedSetupCombo OS Arch

| MissingDependencies [String]

| UnknownCompilerVersion Text CompilerVersion [CompilerVersion]

| UnknownOSKey Text

| GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)

| WantedMustBeGHC

| RequireCustomGHCVariant

| ProblemWhileDecompressing (Path Abs File)

| SetupInfoMissingSevenz

| GHCJSRequiresStandardVariant

| GHCJSNotBooted

| DockerStackExeNotFound Version Text

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 oskey wanted known) = concat

[ "No information found for "

, compilerVersionString wanted

, ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': "

, intercalate ", " (map show 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"

, " https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md\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"]

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

setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)

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

-> m EnvConfig

setupEnv mResolveMissingGHC = do

bconfig <- asks getBuildConfig

let platform = getPlatform bconfig

wc = whichCompiler (bcWantedCompiler bconfig)

sopts = SetupOpts

{ soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig

, soptsUseSystem = configSystemGHC $ bcConfig bconfig

, soptsWantedCompiler = bcWantedCompiler bconfig

, soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig

, soptsStackYaml = Just $ bcStackYaml bconfig

, soptsForceReinstall = False

, soptsSanityCheck = False

, soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig

, soptsSkipMsys = configSkipMsys $ bcConfig bconfig

, soptsUpgradeCabal = False

, soptsResolveMissingGHC = mResolveMissingGHC

, soptsStackSetupYaml = defaultStackSetupYaml

, soptsGHCBindistURL = Nothing

}

mghcBin <- ensureCompiler sopts

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

-- is being used

menv0 <- getMinimalEnvOverride

env <- removeHaskellEnvVars

<$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0)

menv <- mkEnvOverride platform env

compilerVer <- getCompilerVersion menv wc

cabalVer <- getCabalPkgVer menv wc

packages <- mapM

(resolvePackageEntry menv (bcRoot bconfig))

(bcPackageEntries bconfig)

let envConfig0 = EnvConfig

{ envConfigBuildConfig = bconfig

, envConfigCabalVersion = cabalVer

, envConfigCompilerVersion = compilerVer

, envConfigPackages = Map.fromList $ concat packages

}

-- extra installation bin directories

mkDirs <- runReaderT extraBinDirs envConfig0

let mpath = Map.lookup "PATH" env

mkDirs' = map toFilePath . mkDirs

depsPath <- augmentPath (mkDirs' False) mpath

localsPath <- augmentPath (mkDirs' True) mpath

deps <- runReaderT packageDatabaseDeps envConfig0

createDatabase menv wc deps

localdb <- runReaderT packageDatabaseLocal envConfig0

createDatabase menv wc localdb

globaldb <- getGlobalDB menv wc

extras <- runReaderT packageDatabaseExtra envConfig0

let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb

distDir <- runReaderT distRelativeDir envConfig0

executablePath <- liftIO getExecutablePath

utf8EnvVars <- getUtf8LocaleVars menv

envRef <- liftIO $ newIORef Map.empty

let getEnvOverride' es = do

m <- readIORef envRef

case Map.lookup es m of

Just eo -> return eo

Nothing -> do

eo <- mkEnvOverride platform

$ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)

$ (if esIncludeGhcPackagePath es

then Map.insert

(case wc of { Ghc -> "GHC_PACKAGE_PATH"; Ghcjs -> "GHCJS_PACKAGE_PATH" })

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

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

return EnvConfig

{ envConfigBuildConfig = bconfig

{ bcConfig = maybe id addIncludeLib mghcBin

(bcConfig bconfig)

{ configEnvOverride = getEnvOverride' }

}

, envConfigCabalVersion = cabalVer

, envConfigCompilerVersion = compilerVer

, envConfigPackages = envConfigPackages envConfig0

}

-- | 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 T.pack includes)

, configExtraLibDirs = Set.union

(configExtraLibDirs config)

(Set.fromList $ map T.pack libs)

}

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

ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)

=> SetupOpts

-> m (Maybe ExtraDirs)

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

-- Check the available GHCs

menv0 <- getMinimalEnvOverride

msystem <-

if soptsUseSystem sopts

then getSystemCompiler menv0 wc

else return Nothing

Platform expectedArch _ <- asks getPlatform

let needLocal = case msystem of

Nothing -> True

Just _ | soptsSkipGhcCheck sopts -> False

Just (system, arch) ->

not (isWanted system) ||

arch /= expectedArch

isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)

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

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

mtools <- if needLocal

then do

getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager)

localPrograms <- asks $ configLocalPrograms . getConfig

installed <- listInstalled localPrograms

-- Install GHC

ghcVariant <- asks getGHCVariant

config <- asks getConfig

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

let installedCompiler =

case wc of

Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion)

Ghcjs -> getInstalledGhcjs installed isWanted

compilerTool <- case installedCompiler of

Just tool -> return tool

Nothing

| soptsInstallIfMissing sopts -> do

si <- getSetupInfo'

downloadAndInstallCompiler

si

(soptsWantedCompiler sopts)

(soptsCompilerCheck sopts)

(soptsGHCBindistURL sopts)

| otherwise ->

throwM $ CompilerVersionMismatch

msystem

(soptsWantedCompiler sopts, expectedArch)

ghcVariant

(soptsCompilerCheck sopts)

(soptsStackYaml sopts)

(fromMaybe

("Try running \"stack setup\" to install the correct GHC into "

<> T.pack (toFilePath (configLocalPrograms config)))

$ soptsResolveMissingGHC sopts)

-- Install msys2 on windows, if necessary

platform <- asks getPlatform

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

VersionedDownloadInfo version info <-

case Map.lookup osKey $ siMsys2 si of

Just x -> return x

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

return $ Just (compilerTool, mmsys2Tool)

else return Nothing

mpaths <- case mtools of

Nothing -> return Nothing

Just (compilerTool, mmsys2Tool) -> do

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

let idents = catMaybes [Just compilerTool, mmsys2Tool]

paths <- mapM extraDirs idents

return $ Just $ mconcat paths

menv <-

case mpaths of

Nothing -> return menv0

Just ed -> do

config <- asks getConfig

m <- augmentPathMap (edBins ed) (unEnvOverride menv0)

mkEnvOverride (configPlatform config) (removeHaskellEnvVars m)

when (soptsUpgradeCabal sopts) $ do

unless needLocal $ do

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

$logWarn "This may fail, caveat emptor!"

upgradeCabal menv wc

case mtools of

Just (ToolGhcjs cv, _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts)

_ -> return ()

when (soptsSanityCheck sopts) $ sanityCheck menv wc

return mpaths

-- Ensure Docker container-compatible 'stack' executable is downloaded

ensureDockerStackExe

:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

=> Platform -> m (Path Abs File)

ensureDockerStackExe containerPlatform = do

config <- asks getConfig

containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)

let programsPath = configLocalProgramsBase config </> containerPlatformDir

stackVersion = fromCabalVersion Meta.version

tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)

stackExePath <- (</> $(mkRelFile "stack")) <$> installDir programsPath tool

stackExeExists <- fileExists stackExePath

unless stackExeExists $

do

$logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]

si <- getSetupInfo defaultStackSetupYaml =<< asks getHttpManager

osKey <- getOSKey containerPlatform

info <-

case Map.lookup osKey (siStack si) of

Just versions ->

case Map.lookup stackVersion versions of

Just x -> return x

Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)

Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)

_ <-

downloadAndInstallTool

programsPath

si

info

tool

installDockerStackExe

return ()

return stackExePath

-- | Install the newest version of Cabal globally

upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)

=> EnvOverride

-> WhichCompiler

-> m ()

upgradeCabal menv wc = do

let name = $(mkPackageName "Cabal")

rmap <- resolvePackages menv Set.empty (Set.singleton name)

newest <-

case Map.keys rmap of

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

[PackageIdentifier name' version]

| name == name' -> return version

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

installed <- getCabalPkgVer menv wc

if installed >= newest

then $logInfo $ T.concat

[ "Currently installed Cabal is "

, T.pack $ versionString installed

, ", newest is "

, T.pack $ versionString newest

, ". I'm not upgrading Cabal."

]

else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do

$logInfo $ T.concat

[ "Installing Cabal-"

, T.pack $ versionString newest

, " to replace "

, T.pack $ versionString installed

]

let ident = PackageIdentifier name newest

m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)

compilerPath <- join $ findExecutable menv (compilerExeName wc)

newestDir <- parseRelDir $ versionString newest

let installRoot = toFilePath $ parent (parent compilerPath)

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

</> newestDir

dir <-

case Map.lookup ident m of

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

Just dir -> return dir

runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing

platform <- asks getPlatform

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

runCmd (Cmd (Just dir) setupExe menv args) Nothing

runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing

runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing

$logInfo "New Cabal library installed"

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

getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch))

getSystemCompiler menv wc = do

let exeName = case wc of

Ghc -> "ghc"

Ghcjs -> "ghcjs"

exists <- doesExecutableExist menv exeName

if exists

then do

eres <- tryProcessStdout Nothing menv exeName ["--info"]

let minfo = do

Right bs <- Just eres

pairs <- readMay $ S8.unpack bs :: 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 menv 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

:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)

=> String -> Manager -> m SetupInfo

getSetupInfo stackSetupYaml manager = do

config <- asks getConfig

setupInfos <-

mapM

loadSetupInfo

(SetupInfoFileOrURL stackSetupYaml :

configSetupInfoLocations config)

return (mconcat setupInfos)

where

loadSetupInfo (SetupInfoInline si) = return si

loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do

bs <-

case parseUrl urlOrFile of

Just req -> do

bss <-

liftIO $

flip runReaderT manager $

withResponse req $

\res ->

responseBody res $$ CL.consume

return $ S8.concat bss

Nothing -> liftIO $ S.readFile urlOrFile

(si,warnings) <- either throwM return (Yaml.decodeEither' bs)

when (urlOrFile /= defaultStackSetupYaml) $

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 -> 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 :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

=> Path Abs Dir

-> SetupInfo

-> DownloadInfo

-> Tool

-> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ())

-> m Tool

downloadAndInstallTool programsDir si downloadInfo tool installer = do

(file, at) <- downloadFromInfo programsDir downloadInfo tool

dir <- installDir programsDir tool

unmarkInstalled programsDir tool

installer si file at dir

markInstalled programsDir tool

return tool

downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)

=> SetupInfo

-> CompilerVersion

-> VersionCheck

-> Maybe String

-> m Tool

downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do

ghcVariant <- asks getGHCVariant

(selectedVersion, downloadInfo) <- case mbindistURL of

Just bindistURL -> do

case ghcVariant of

GHCCustom _ -> return ()

_ -> throwM RequireCustomGHCVariant

case wanted of

GhcVersion version ->

return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing)

_ ->

throwM WantedMustBeGHC

_ -> do

ghcKey <- getGhcKey

case Map.lookup ghcKey $ siGHCs si of

Nothing -> throwM $ UnknownOSKey ghcKey

Just pairs -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs

config <- asks getConfig

let installer =

case configPlatform config of

Platform _ Cabal.Windows -> installGHCWindows selectedVersion

_ -> installGHCPosix selectedVersion

$logInfo $

"Preparing to install GHC" <>

(case ghcVariant of

GHCStandard -> ""

v -> " (" <> T.pack (ghcVariantName v) <> ")") <>

" to an isolated location."

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

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

let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion

downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer

downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do

config <- asks getConfig

ghcVariant <- asks getGHCVariant

case ghcVariant of

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

installer = installGHCJS $ case selectedVersion of

GhcjsVersion version _ -> version

_ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler."

downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer

getWantedCompilerInfo :: (Ord k, MonadThrow m)

=> Text

-> VersionCheck

-> CompilerVersion

-> (k -> CompilerVersion)

-> Map k a

-> m (k, a)

getWantedCompilerInfo key versionCheck wanted toCV pairs =

case mpair of

Just pair -> return pair

Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs))

where

mpair =

listToMaybe $

sortBy (flip (comparing fst)) $

filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs)

getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)

=> m Text

getGhcKey = do

ghcVariant <- asks getGHCVariant

platform <- asks getPlatform

osKey <- getOSKey platform

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

getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO 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 arch os -> throwM $ UnsupportedSetupCombo os arch

downloadFromInfo

:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

=> Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType)

downloadFromInfo programsDir downloadInfo tool = do

at <-

case extension of

".tar.xz" -> return TarXz

".tar.bz2" -> return TarBz2

".tar.gz" -> return TarGz

".7z.exe" -> return SevenZ

_ -> error $ "Unknown extension for url: " ++ T.unpack url

relfile <- parseRelFile $ toolString tool ++ extension

let path = programsDir </> relfile

chattyDownload (T.pack (toolString tool)) downloadInfo path

return (path, at)

where

url = downloadInfoUrl downloadInfo

extension =

loop $ T.unpack 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 :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

=> Version

-> SetupInfo

-> Path Abs File

-> ArchiveType

-> Path Abs Dir

-> m ()

installGHCPosix version _ archiveFile archiveType destDir = do

platform <- asks getPlatform

menv0 <- getMinimalEnvOverride

menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))

$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))

zipTool' <-

case archiveType of

TarXz -> return "xz"

TarBz2 -> return "bzip2"

TarGz -> return "gzip"

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

(zipTool, makeTool, tarTool) <- checkDependencies $ (,,)

<$> checkDependency zipTool'

<*> (checkDependency "gmake" <|> checkDependency "make")

<*> checkDependency "tar"

$logDebug $ "ziptool: " <> T.pack zipTool

$logDebug $ "make: " <> T.pack makeTool

$logDebug $ "tar: " <> T.pack tarTool

withCanonicalizedSystemTempDirectory "stack-setup" $ \root -> do

dir <-

liftM (root </>) $

parseRelDir $

"ghc-" ++ versionString version

$logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."]

$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)

readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing

$logSticky "Configuring GHC ..."

readInNull dir (toFilePath $ dir </> $(mkRelFile "configure"))

menv ["--prefix=" ++ toFilePath destDir] Nothing

$logSticky "Installing GHC ..."

readInNull dir makeTool menv ["install"] Nothing

$logStickyDone $ "Installed GHC."

$logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)

installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)

=> Version

-> SetupInfo

-> Path Abs File

-> ArchiveType

-> Path Abs Dir

-> m ()

installGHCJS version si archiveFile archiveType destDir = do

platform <- asks getPlatform

menv0 <- getMinimalEnvOverride

-- This ensures that locking is disabled for the invocations of

-- stack below.

let removeLockVar = Map.delete "STACK_LOCK"

menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0)))

$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))

-- NOTE: this is a bit of a hack - instead of using a temp

-- directory, leave the unpacked source tarball in the destination

-- directory. This way, the absolute paths in the wrapper scripts

-- will point to executables that exist in

-- src/.stack-work/install/... - see

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

--

-- This is also used by 'ensureGhcjsBooted', because it can use the

-- environment of the stack.yaml which came with ghcjs, in order to

-- install cabal-install. This lets us also fix the version of

-- cabal-install used.

let unpackDir = destDir </> $(mkRelDir "src")

tarComponent <- parseRelDir ("ghcjs-" ++ versionString version)

runUnpack <- case platform of

Platform _ Cabal.Windows -> return $

withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir

_ -> do

zipTool' <-

case archiveType of

TarXz -> return "xz"

TarBz2 -> return "bzip2"

TarGz -> return "gzip"

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

(zipTool, tarTool) <- checkDependencies $ (,)

<$> checkDependency zipTool'

<*> checkDependency "tar"

$logDebug $ "ziptool: " <> T.pack zipTool

$logDebug $ "tar: " <> T.pack tarTool

return $ do

removeTreeIfExists unpackDir

readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing

renameDir (destDir </> tarComponent) unpackDir

$logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."]

$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)

runUnpack

$logSticky "Setting up GHCJS build environment"

let stackYaml = unpackDir </> $(mkRelFile "stack.yaml")

destBinDir = destDir </> $(mkRelDir "bin")

createTree destBinDir

envConfig <- loadGhcjsEnvConfig stackYaml destBinDir

-- On windows we need to copy options files out of the install dir. Argh!

-- This is done before the build, so that if it fails, things fail

-- earlier.

mwindowsInstallDir <- case platform of

Platform _ Cabal.Windows ->

liftM Just $ runInnerStackT envConfig installationRootLocal

_ -> return Nothing

$logSticky "Installing GHCJS (this will take a long time) ..."

runInnerStackT envConfig $

build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True }

-- Copy over *.options files needed on windows.

forM_ mwindowsInstallDir $ \dir -> do

(_, files) <- listDirectory (dir </> $(mkRelDir "bin"))

forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do

let dest = destDir </> $(mkRelDir "bin") </> filename optionsFile

removeFileIfExists dest

copyFile optionsFile dest

$logStickyDone "Installed GHCJS."

-- Install the downloaded stack binary distribution

installDockerStackExe

:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

=> SetupInfo

-> Path Abs File

-> ArchiveType

-> Path Abs Dir

-> m ()

installDockerStackExe _ archiveFile _ destDir = do

(_,tarTool) <-

checkDependencies $

(,) <$> checkDependency "gzip" <*> checkDependency "tar"

menv <- getMinimalEnvOverride

createTree destDir

readInNull

destDir

tarTool

menv

["xf", toFilePath archiveFile, "--strip-components", "1"]

Nothing

ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)

=> EnvOverride -> CompilerVersion -> Bool -> m ()

ensureGhcjsBooted menv cv shouldBoot = do

eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ())

case eres of

Right () -> return ()

Left (ReadProcessException _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err ->

return ()

Left (ReadProcessException _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err ->

if not shouldBoot then throwM GHCJSNotBooted else do

config <- asks getConfig

destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv)

let stackYaml = destDir </> $(mkRelFile "src/stack.yaml")

-- TODO: Remove 'actualStackYaml' and just use

-- 'stackYaml' for a version after 0.1.6. It's for

-- compatibility with the directories setup used for

-- most of the life of the development branch between

-- 0.1.5 and 0.1.6. See

-- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783

-- This only affects the case where GHCJS has been

-- installed with an older version and not yet booted.

stackYamlExists <- fileExists stackYaml

actualStackYaml <- if stackYamlExists then return stackYaml

else case cv of

GhcjsVersion version _ ->

liftM ((destDir </> $(mkRelDir "src")) </>) $

parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml"

_ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion"

actualStackYamlExists <- fileExists actualStackYaml

unless actualStackYamlExists $

fail "Couldn't find GHCJS stack.yaml in old or new location."

bootGhcjs actualStackYaml destDir

Left err -> throwM err

bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)

=> Path Abs File -> Path Abs Dir -> m ()

bootGhcjs stackYaml destDir = do

envConfig <- loadGhcjsEnvConfig stackYaml (destDir </> $(mkRelDir "bin"))

menv <- liftIO $ configEnvOverride (getConfig envConfig) defaultEnvSettings

-- Install cabal-install if missing, or if the installed one is old.

mcabal <- getCabalInstallVersion menv

shouldInstallCabal <- case mcabal of

Nothing -> do

$logInfo "No cabal-install binary found for use with GHCJS. Installing a local copy of cabal-install from source."

return True

Just v

| v < $(mkVersion "1.22.4") -> do

$logInfo $

"cabal-install found on PATH is too old to be used for booting GHCJS (version " <>

versionText v <>

"). Installing a local copy of cabal-install from source."

return True

| otherwise -> return False

when shouldInstallCabal $ do

$logSticky "Building cabal-install for use by ghcjs-boot ... "

runInnerStackT envConfig $

build (\_ -> return ())

Nothing

defaultBuildOpts { boptsTargets = ["cabal-install"] }

$logSticky "Booting GHCJS (this will take a long time) ..."

let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False }

menv' <- liftIO $ configEnvOverride (getConfig envConfig) envSettings

runAndLog Nothing "ghcjs-boot" menv' ["--clean"]

$logStickyDone "GHCJS booted."

-- TODO: something similar is done in Stack.Build.Execute. Create some utilities

-- for this?

runAndLog :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)

=> Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m ()

runAndLog mdir name menv args = liftBaseWith $ \restore -> do

let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr)

void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines

loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r)

=> Path Abs File -> Path b t -> m EnvConfig

loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do

lc <- loadConfig

(mempty

{ configMonoidInstallGHC = Just True

, configMonoidLocalBinPath = Just (toFilePath binPath)

})

(Just stackYaml)

Nothing

bconfig <- lcLoadBuildConfig lc Nothing

runInnerStackT bconfig $ setupEnv Nothing

getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m)

=> EnvOverride -> m (Maybe Version)

getCabalInstallVersion menv = do

ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"]

case ebs of

Left _ -> return Nothing

Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs))