{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
module Stack.Setup
( setupEnv
, ensureGHC
, 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 Crypto.Hash (SHA1(SHA1))
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Foldable hiding (concatMap, or)
import Data.IORef
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (concat, elem, maximumBy)
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 Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.IO
import Prelude hiding (concat, elem)
import Safe (readMay)
import Stack.Types.Build
import Stack.Config (resolvePackageEntry)
import Stack.Constants (distRelativeDir)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)
import Stack.Solver (getCompilerVersion)
import Stack.Types
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.IO.Temp (withSystemTempDirectory)
import System.Process (rawSystem)
import System.Process.Read
import System.Process.Run (runIn)
import System.IO.Temp (withTempDirectory)
import Text.Printf (printf)
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))
, soptsForceReinstall :: !Bool
, soptsSanityCheck :: !Bool
, soptsSkipGhcCheck :: !Bool
, soptsSkipMsys :: !Bool
, soptsUpgradeCabal :: !Bool
, soptsResolveMissingGHC :: !(Maybe Text)
, soptsStackSetupYaml :: !String
, soptsGHCBindistURL :: !(Maybe String)
}
deriving Show
data SetupException = UnsupportedSetupCombo OS Arch
| MissingDependencies [String]
| UnknownCompilerVersion Text CompilerVersion (Set Version)
| UnknownOSKey Text
| GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)
| WantedMustBeGHC
| RequireCustomGHCVariant
| ProblemWhileDecompressing (Path Abs File)
| SetupInfoMissingSevenz
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 "
, T.unpack (compilerVersionName wanted)
, ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': "
, intercalate ", " (map show $ 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"
, " https://github.com/commercialhaskell/stack/blob/master/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"
setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m)
=> Maybe Text
-> 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 <- ensureGHC sopts
menv0 <- getMinimalEnvOverride
let 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
}
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
let mkGPP locals = mkGhcPackagePath locals localdb deps 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)
$ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSlash deps)
$ Map.insert "HASKELL_PACKAGE_SANDBOXES"
(T.pack $ if esIncludeLocals es
then intercalate [searchPathSeparator]
[ toFilePathNoTrailingSlash localdb
, toFilePathNoTrailingSlash deps
, ""
]
else intercalate [searchPathSeparator]
[ toFilePathNoTrailingSlash deps
, ""
])
$ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSlash 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
}
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)
}
data ExtraDirs = ExtraDirs
{ edBins :: ![FilePath]
, edInclude :: ![FilePath]
, edLib :: ![FilePath]
}
instance Monoid ExtraDirs where
mempty = ExtraDirs [] [] []
mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs
(a ++ x)
(b ++ y)
(c ++ z)
ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m)
=> SetupOpts
-> m (Maybe ExtraDirs)
ensureGHC 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 ""
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)
mpaths <- if needLocal
then do
getSetupInfo' <- runOnce (getSetupInfo sopts =<< asks getHttpManager)
installed <- listInstalled
ghcVariant <- asks getGHCVariant
config <- asks getConfig
ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
ghcIdent <- case getInstalledTool installed ghcPkgName (isWanted . GhcVersion) of
Just ident -> return ident
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
downloadAndInstallGHC
si
(soptsWantedCompiler sopts)
(soptsCompilerCheck sopts)
(soptsGHCBindistURL sopts)
| otherwise -> do
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)
platform <- asks getPlatform
mmsys2Ident <- case platform of
Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
case getInstalledTool installed $(mkPackageName "msys2") (const True) of
Just ident -> return (Just ident)
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
osKey <- getOSKey
VersionedDownloadInfo version info <-
case Map.lookup osKey $ siMsys2 si of
Just x -> return x
Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey
Just <$> downloadAndInstallTool si info $(mkPackageName "msys2") version (installMsys2Windows osKey)
| otherwise -> do
$logWarn "Continuing despite missing tool: msys2"
return Nothing
_ -> return Nothing
let idents = catMaybes [Just ghcIdent, mmsys2Ident]
paths <- mapM extraDirs idents
return $ Just $ mconcat paths
else return Nothing
menv <-
case mpaths of
Nothing -> return menv0
Just ed -> do
config <- asks getConfig
let m0 = unEnvOverride menv0
path0 = Map.lookup "PATH" m0
path = augmentPath (edBins ed) path0
m = Map.insert "PATH" path m0
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
when (soptsSanityCheck sopts) $ sanityCheck menv
return mpaths
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 withSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
$logInfo $ T.concat
[ "Installing Cabal-"
, T.pack $ versionString newest
, " to replace "
, T.pack $ versionString installed
]
tmpdir' <- parseAbsDir tmpdir
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
runIn 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'
]
runIn dir setupExe menv
( "configure"
: map dirArgument (words "lib bin data doc")
)
Nothing
runIn dir setupExe menv ["build"] Nothing
runIn dir setupExe menv ["install"] Nothing
$logInfo "New Cabal library installed"
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
getSetupInfo
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)
=> SetupOpts -> Manager -> m SetupInfo
getSetupInfo sopts manager = do
config <- asks getConfig
setupInfos <-
mapM
loadSetupInfo
(SetupInfoFileOrURL (soptsStackSetupYaml sopts) :
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)
logJSONWarnings urlOrFile warnings
return si
markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> PackageIdentifier
-> m ()
markInstalled ident = do
dir <- asks $ configLocalPrograms . getConfig
fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed"
liftIO $ writeFile (toFilePath $ dir </> fpRel) "installed"
unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> PackageIdentifier
-> m ()
unmarkInstalled ident = do
dir <- asks $ configLocalPrograms . getConfig
fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed"
removeFileIfExists $ dir </> fpRel
listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> m [PackageIdentifier]
listInstalled = do
dir <- asks $ configLocalPrograms . getConfig
createTree dir
(_, files) <- listDirectory dir
return $ mapMaybe toIdent files
where
toIdent fp = do
x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp
parsePackageIdentifierFromString $ T.unpack x
installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)
=> PackageIdentifier
-> m (Path Abs Dir)
installDir ident = do
config <- asks getConfig
reldir <- parseRelDir $ packageIdentifierString ident
return $ configLocalPrograms config </> reldir
extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)
=> PackageIdentifier
-> m ExtraDirs
extraDirs ident = do
platform <- asks getPlatform
dir <- installDir ident
case (platform, packageNameString $ packageIdentifierName ident) of
(Platform _ Cabal.Windows, isGHC -> True) -> return mempty
{ edBins = goList
[ dir </> $(mkRelDir "bin")
, dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")
]
}
(Platform _ Cabal.Windows, "msys2") -> return mempty
{ edBins = goList
[ dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")
]
, edInclude = goList
[ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "include")
, dir </> $(mkRelDir "mingw32") </> $(mkRelDir "include")
]
, edLib = goList
[ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "lib")
, dir </> $(mkRelDir "mingw32") </> $(mkRelDir "lib")
]
}
(_, isGHC -> True) -> return mempty
{ edBins = goList
[ dir </> $(mkRelDir "bin")
]
}
(Platform _ x, tool) -> do
$logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool))
return mempty
where
goList = map toFilePathNoTrailingSlash
isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n
getInstalledTool :: [PackageIdentifier]
-> PackageName
-> (Version -> Bool)
-> Maybe PackageIdentifier
getInstalledTool installed name goodVersion =
if null available
then Nothing
else Just $ maximumBy (comparing packageIdentifierVersion) available
where
available = filter goodPackage installed
goodPackage pi' =
packageIdentifierName pi' == name &&
goodVersion (packageIdentifierVersion pi')
downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> DownloadInfo
-> PackageName
-> Version
-> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> PackageIdentifier -> m ())
-> m PackageIdentifier
downloadAndInstallTool si downloadInfo name version installer = do
let ident = PackageIdentifier name version
(file, at) <- downloadFromInfo downloadInfo ident
dir <- installDir ident
unmarkInstalled ident
installer si file at dir ident
markInstalled ident
return ident
downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> CompilerVersion
-> VersionCheck
-> (Maybe String)
-> m PackageIdentifier
downloadAndInstallGHC si wanted 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
pairs <-
case Map.lookup ghcKey $ siGHCs si of
Nothing -> throwM $ UnknownOSKey ghcKey
Just pairs -> return pairs
let mpair =
listToMaybe $
sortBy (flip (comparing fst)) $
filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs)
case mpair of
Just pair -> return pair
Nothing -> throwM $ UnknownCompilerVersion ghcKey wanted (Map.keysSet pairs)
platform <- asks getPlatform
let installer =
case platform of
Platform _ Cabal.Windows -> installGHCWindows
_ -> installGHCPosix
$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)
downloadAndInstallTool si downloadInfo ghcPkgName selectedVersion installer
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
osKey <- getOSKey
return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)
getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> m Text
getOSKey = do
platform <- asks getPlatform
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)
=> DownloadInfo
-> PackageIdentifier
-> m (Path Abs File, ArchiveType)
downloadFromInfo downloadInfo ident = do
config <- asks getConfig
at <-
case extension of
".tar.xz" -> return TarXz
".tar.bz2" -> return TarBz2
".7z.exe" -> return SevenZ
_ -> error $ "Unknown extension: " ++ extension
relfile <- parseRelFile $ packageIdentifierString ident ++ extension
let path = configLocalPrograms config </> relfile
chattyDownload (packageIdentifierText ident) downloadInfo path
return (path, at)
where
url = downloadInfoUrl downloadInfo
extension =
loop $ T.unpack url
where
loop fp
| ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z"] = loop fp' ++ ext
| otherwise = ""
where
(fp', ext) = FP.splitExtension fp
data ArchiveType
= TarBz2
| TarXz
| SevenZ
installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> PackageIdentifier
-> m ()
installGHCPosix _ archiveFile archiveType destDir ident = 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"
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
withSystemTempDirectory "stack-setup" $ \root' -> do
root <- parseAbsDir root'
dir <-
liftM (root Path.</>) $
parseRelDir $
"ghc-" ++ versionString (packageIdentifierVersion ident)
$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 Path.</> $(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)
where
checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)
=> CheckDependency a -> m a
checkDependencies (CheckDependency f) = do
menv <- getMinimalEnvOverride
liftIO (f menv) >>= either (throwM . MissingDependencies) return
checkDependency :: String -> CheckDependency String
checkDependency tool = CheckDependency $ \menv -> do
exists <- doesExecutableExist menv tool
return $ if exists then Right tool else Left [tool]
newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a))
deriving Functor
instance Applicative CheckDependency where
pure x = CheckDependency $ \_ -> return (Right x)
CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do
f' <- f menv
x' <- x menv
return $
case (f', x') of
(Left e1, Left e2) -> Left $ e1 ++ e2
(Left e, Right _) -> Left e
(Right _, Left e) -> Left e
(Right f'', Right x'') -> Right $ f'' x''
instance Alternative CheckDependency where
empty = CheckDependency $ \_ -> return $ Left []
CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do
res1 <- x menv
case res1 of
Left _ -> y menv
Right x' -> return $ Right x'
installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> PackageIdentifier
-> m ()
installGHCWindows si archiveFile archiveType destDir ident = do
suffix <-
case archiveType of
TarXz -> return ".xz"
TarBz2 -> return ".bz2"
_ -> error $ "GHC on Windows must be a tarball file"
tarFile <-
case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of
Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile
Just x -> parseAbsFile $ T.unpack x
run7z <- setup7z si
withTempDirectory (toFilePath $ parent destDir)
((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do
tmpDir <- parseAbsDir tmpDir0
run7z (parent archiveFile) archiveFile
run7z tmpDir tarFile
removeFile tarFile `catchIO` \e ->
$logWarn (T.concat
[ "Exception when removing "
, T.pack $ toFilePath tarFile
, ": "
, T.pack $ show e
])
tarComponent <- parseRelDir $ "ghc-" ++ versionString (packageIdentifierVersion ident)
renameDir (tmpDir </> tarComponent) destDir
$logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)
installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Text
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> PackageIdentifier
-> m ()
installMsys2Windows osKey si archiveFile archiveType destDir _ = do
suffix <-
case archiveType of
TarXz -> return ".xz"
TarBz2 -> return ".bz2"
_ -> error $ "MSYS2 must be a .tar.xz archive"
tarFile <-
case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of
Nothing -> error $ "Invalid MSYS2 filename: " ++ show archiveFile
Just x -> parseAbsFile $ T.unpack x
run7z <- setup7z si
exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do
$logError $ T.pack $
"Could not delete existing msys directory: " ++
toFilePath destDir
throwM e
run7z (parent archiveFile) archiveFile
run7z (parent archiveFile) tarFile
removeFile tarFile `catchIO` \e ->
$logWarn (T.concat
[ "Exception when removing "
, T.pack $ toFilePath tarFile
, ": "
, T.pack $ show e
])
msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)
liftIO $ D.renameDirectory
(toFilePath $ parent archiveFile </> msys)
(toFilePath destDir)
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
let oldEnv = unEnvOverride menv0
newEnv = augmentPathMap
[toFilePath $ destDir </> $(mkRelDir "usr") </> $(mkRelDir "bin")]
oldEnv
menv <- mkEnvOverride platform newEnv
runIn destDir "sh" menv ["--login", "-c", "true"] Nothing
runIn destDir "pacman" menv ["-Sy", "--noconfirm", "git"] Nothing
setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m)
=> SetupInfo
-> m (Path Abs Dir -> Path Abs File -> n ())
setup7z si = do
dir <- asks $ configLocalPrograms . getConfig
let exe = dir </> $(mkRelFile "7z.exe")
dll = dir </> $(mkRelFile "7z.dll")
case (siSevenzDll si, siSevenzExe si) of
(Just sevenzDll, Just sevenzExe) -> do
chattyDownload "7z.dll" sevenzDll dll
chattyDownload "7z.exe" sevenzExe exe
return $ \outdir archive -> liftIO $ do
ec <- rawSystem (toFilePath exe)
[ "x"
, "-o" ++ toFilePath outdir
, "-y"
, toFilePath archive
]
when (ec /= ExitSuccess)
$ throwM (ProblemWhileDecompressing archive)
_ -> throwM SetupInfoMissingSevenz
chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
=> Text
-> DownloadInfo
-> Path Abs File
-> m ()
chattyDownload label downloadInfo path = do
let url = downloadInfoUrl downloadInfo
req <- parseUrl $ T.unpack url
$logSticky $ T.concat
[ "Preparing to download "
, label
, " ..."
]
$logDebug $ T.concat
[ "Downloading from "
, url
, " to "
, T.pack $ toFilePath path
, " ..."
]
hashChecks <- case downloadInfoSha1 downloadInfo of
Just sha1ByteString -> do
let sha1 = CheckHexDigestByteString sha1ByteString
$logDebug $ T.concat
[ "Will check against sha1 hash: "
, T.decodeUtf8With T.lenientDecode sha1ByteString
]
return [HashCheck SHA1 sha1]
Nothing -> do
$logWarn $ T.concat
[ "No sha1 found in metadata,"
, " download hash won't be checked."
]
return []
let dReq = DownloadRequest
{ drRequest = req
, drHashChecks = hashChecks
, drLengthCheck = mtotalSize
, drRetryPolicy = drRetryPolicyDefault
}
runInBase <- liftBaseWith $ \run -> return (void . run)
x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)
if x
then $logStickyDone ("Downloaded " <> label <> ".")
else $logStickyDone "Already downloaded."
where
mtotalSize = downloadInfoContentLength downloadInfo
chattyDownloadProgress runInBase _ = do
_ <- liftIO $ runInBase $ $logSticky $
label <> ": download has begun"
CL.map (Sum . S.length)
=$ chunksOverTime 1
=$ go
where
go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
modify (+ size)
totalSoFar <- get
liftIO $ runInBase $ $logSticky $ T.pack $
case mtotalSize of
Nothing -> chattyProgressNoTotal totalSoFar
Just 0 -> chattyProgressNoTotal totalSoFar
Just totalSize -> chattyProgressWithTotal totalSoFar totalSize
chattyProgressNoTotal totalSoFar =
printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
(T.unpack label)
chattyProgressWithTotal totalSoFar total =
printf ("%s: " <>
bytesfmt "%7.2f" totalSoFar <> " / " <>
bytesfmt "%.2f" total <>
" (%6.2f%%) downloaded...")
(T.unpack label)
percentage
where percentage :: Double
percentage = (fromIntegral totalSoFar / fromIntegral total * 100)
bytesfmt :: Integral a => String -> a -> String
bytesfmt formatter bs = printf (formatter <> " %s")
(fromIntegral (signum bs) * dec :: Double)
(bytesSuffixes !! i)
where
(dec,i) = getSuffix (abs bs)
getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)
where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)
bytesSuffixes :: [String]
bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]
chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> Conduit a m a
chunksOverTime diff = do
currentTime <- liftIO getCurrentTime
evalStateC (currentTime, mempty) go
where
go = await >>= \case
Nothing -> do
(_, acc) <- get
yield acc
Just a -> do
(lastTime, acc) <- get
let acc' = acc <> a
currentTime <- liftIO getCurrentTime
if diff < diffUTCTime currentTime lastTime
then put (currentTime, mempty) >> yield acc'
else put (lastTime, acc')
go
sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> m ()
sanityCheck menv = withSystemTempDirectory "stack-sanity-check" $ \dir -> do
dir' <- parseAbsDir dir
let fp = toFilePath $ dir' </> $(mkRelFile "Main.hs")
liftIO $ writeFile fp $ unlines
[ "import Distribution.Simple"
, "main = putStrLn \"Hello World\""
]
ghc <- join $ findExecutable menv "ghc"
$logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc)
eres <- tryProcessStdout (Just dir') menv "ghc"
[ fp
, "-no-user-package-db"
]
case eres of
Left e -> throwM $ GHCSanityCheckCompileFailed e ghc
Right _ -> return ()
toFilePathNoTrailingSlash :: Path loc Dir -> FilePath
toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
Map.delete "GHCJS_PACKAGE_PATH" .
Map.delete "GHC_PACKAGE_PATH" .
Map.delete "HASKELL_PACKAGE_SANDBOX" .
Map.delete "HASKELL_PACKAGE_SANDBOXES" .
Map.delete "HASKELL_DIST_DIR"
getUtf8LocaleVars
:: forall m env.
(MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)
=> EnvOverride -> m (Map Text Text)
getUtf8LocaleVars menv = do
Platform _ os <- asks getPlatform
if os == Cabal.Windows
then
return
Map.empty
else do
let checkedVars = map checkVar (Map.toList $ eoTextMap menv)
needChangeVars = concatMap fst checkedVars
existingVarNames = Set.unions (map snd checkedVars)
hasAnyExisting =
or $
map
(`Set.member` existingVarNames)
["LANG", "LANGUAGE", "LC_ALL"]
if null needChangeVars && hasAnyExisting
then
return
Map.empty
else do
elocales <- tryProcessStdout Nothing menv "locale" ["-a"]
let
utf8Locales =
case elocales of
Left _ -> []
Right locales ->
filter
isUtf8Locale
(T.lines $
T.decodeUtf8With
T.lenientDecode
locales)
mfallback = getFallbackLocale utf8Locales
when
(isNothing mfallback)
($logWarn
"Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")
let
changes =
Map.unions $
map
(adjustedVarValue utf8Locales mfallback)
needChangeVars
adds
| hasAnyExisting =
Map.empty
| otherwise =
case mfallback of
Nothing -> Map.empty
Just fallback ->
Map.singleton "LANG" fallback
return (Map.union changes adds)
where
checkVar
:: (Text, Text) -> ([Text], Set Text)
checkVar (k,v) =
if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k
then if isUtf8Locale v
then ([], Set.singleton k)
else ([k], Set.singleton k)
else ([], Set.empty)
adjustedVarValue
:: [Text] -> Maybe Text -> Text -> Map Text Text
adjustedVarValue utf8Locales mfallback k =
case Map.lookup k (eoTextMap menv) of
Nothing -> Map.empty
Just v ->
case concatMap
(matchingLocales utf8Locales)
[ T.takeWhile (/= '.') v <> "."
, T.takeWhile (/= '_') v <> "_"] of
(v':_) -> Map.singleton k v'
[] ->
case mfallback of
Just fallback -> Map.singleton k fallback
Nothing -> Map.empty
getFallbackLocale
:: [Text] -> Maybe Text
getFallbackLocale utf8Locales = do
case concatMap (matchingLocales utf8Locales) fallbackPrefixes of
(v:_) -> Just v
[] ->
case utf8Locales of
[] -> Nothing
(v:_) -> Just v
matchingLocales
:: [Text] -> Text -> [Text]
matchingLocales utf8Locales prefix =
filter
(\v ->
(T.toLower prefix) `T.isPrefixOf` T.toLower v)
utf8Locales
isUtf8Locale locale =
or $
map
(\v ->
T.toLower v `T.isSuffixOf` T.toLower locale)
utf8Suffixes
fallbackPrefixes = ["C.", "en_US.", "en_"]
utf8Suffixes = [".UTF-8", ".utf8"]