stack-0.1.3.0: src/Stack/Setup.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Stack.Setup
( setupEnv
, ensureGHC
, SetupOpts (..)
) where
import Control.Applicative
import Control.Exception.Enclosed (catchIO)
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 Data.ByteString (ByteString)
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.IORef
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe, catMaybes, fromMaybe)
import Data.Monoid
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 Distribution.Text (simpleParse)
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.IO
import Prelude -- Fix AMP warning
import Safe (headMay, readMay)
import Stack.Types.Build
import Stack.Config (resolvePackageEntry)
import Stack.Constants (distRelativeDir)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB)
import Stack.Solver (getGhcVersion)
import Stack.Types
import Stack.Types.StackT
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 Text.Printf (printf)
data SetupOpts = SetupOpts
{ soptsInstallIfMissing :: !Bool
, soptsUseSystem :: !Bool
, soptsExpected :: !Version
, 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.
}
deriving Show
data SetupException = UnsupportedSetupCombo OS Arch
| MissingDependencies [String]
| UnknownGHCVersion Text Version (Set MajorVersion)
| UnknownOSKey Text
| GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)
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 (UnknownGHCVersion oskey version known) = concat
[ "No information found for GHC version "
, versionString version
, ".\nSupported GHC major 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/wiki/Downloads\n\n"
, "for more information. Exception was:\n"
, show e
]
-- | 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, MonadBaseControl IO m)
=> m EnvConfig
setupEnv = do
bconfig <- asks getBuildConfig
let platform = getPlatform bconfig
sopts = SetupOpts
{ soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig
, soptsUseSystem = configSystemGHC $ bcConfig bconfig
, soptsExpected = bcGhcVersionExpected bconfig
, soptsStackYaml = Just $ bcStackYaml bconfig
, soptsForceReinstall = False
, soptsSanityCheck = False
, soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig
, soptsSkipMsys = configSkipMsys $ bcConfig bconfig
, soptsUpgradeCabal = False
}
mghcBin <- ensureGHC sopts
menv0 <- getMinimalEnvOverride
-- Modify the initial environment to include the GHC path, if a local GHC
-- is being used
let env = removeHaskellEnvVars $ case mghcBin of
Nothing -> unEnvOverride menv0
Just ghcBin ->
let x = unEnvOverride menv0
mpath = Map.lookup "PATH" x
path = T.intercalate (T.singleton searchPathSeparator)
$ map (stripTrailingSlashT . T.pack) ghcBin
++ maybe [] return mpath
in Map.insert "PATH" path x
menv <- mkEnvOverride platform env
ghcVer <- getGhcVersion menv
cabalVer <- getCabalPkgVer menv
packages <- mapM
(resolvePackageEntry menv (bcRoot bconfig))
(bcPackageEntries bconfig)
let envConfig0 = EnvConfig
{ envConfigBuildConfig = bconfig
, envConfigCabalVersion = cabalVer
, envConfigGhcVersion = ghcVer
, 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 deps
localdb <- runReaderT packageDatabaseLocal envConfig0
createDatabase menv localdb
globalDB <- getGlobalDB menv
let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSlash localdb | locals]
, [toFilePathNoTrailingSlash deps]
, [toFilePathNoTrailingSlash globalDB]
]
distDir <- runReaderT distRelativeDir envConfig0
executablePath <- liftIO getExecutablePath
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 "GHC_PACKAGE_PATH" (mkGPP (esIncludeLocals es))
else id)
$ (if esStackExe es
then Map.insert "STACK_EXE" (T.pack executablePath)
else id)
-- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70
$ 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 = (bcConfig bconfig) { configEnvOverride = getEnvOverride' }
}
, envConfigCabalVersion = cabalVer
, envConfigGhcVersion = ghcVer
, envConfigPackages = envConfigPackages envConfig0
}
-- | Augment the PATH environment variable with the given extra paths
augmentPath :: [FilePath] -> Maybe Text -> Text
augmentPath dirs mpath =
T.pack $ intercalate [searchPathSeparator]
(map stripTrailingSlashS dirs ++ maybe [] (return . T.unpack) mpath)
where
stripTrailingSlashS = T.unpack . stripTrailingSlashT . T.pack
stripTrailingSlashT :: Text -> Text
stripTrailingSlashT t = fromMaybe t $ T.stripSuffix
(T.singleton FP.pathSeparator)
t
-- | Ensure GHC is installed and provide the PATHs to add if necessary
ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupOpts
-> m (Maybe [FilePath])
ensureGHC sopts = do
when (getMajorVersion expected < MajorVersion 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 getSystemGHC menv0
else return Nothing
Platform expectedArch _ <- asks getPlatform
let needLocal = case msystem of
Nothing -> True
Just _ | soptsSkipGhcCheck sopts -> False
Just (system, arch) ->
-- we allow a newer version of GHC within the same major series
getMajorVersion system /= getMajorVersion expected ||
expected > system ||
arch /= expectedArch
-- If we need to install a GHC, try to do so
mpaths <- if needLocal
then do
config <- asks getConfig
let tools =
case configPlatform config of
Platform _ os | isWindows os ->
($(mkPackageName "ghc"), Just expected)
: (if soptsSkipMsys sopts
then []
else [($(mkPackageName "git"), Nothing)])
_ ->
[ ($(mkPackageName "ghc"), Just expected)
]
-- Avoid having to load it twice
siRef <- liftIO $ newIORef Nothing
manager <- asks getHttpManager
let getSetupInfo' = liftIO $ do
msi <- readIORef siRef
case msi of
Just si -> return si
Nothing -> do
si <- getSetupInfo manager
writeIORef siRef $ Just si
return si
installed <- runReaderT listInstalled config
idents <- mapM (ensureTool menv0 sopts installed getSetupInfo' msystem) tools
paths <- runReaderT (mapM binDirs $ catMaybes idents) config
return $ Just $ map toFilePathNoTrailingSlash $ concat paths
else return Nothing
menv <-
case mpaths of
Nothing -> return menv0
Just paths -> do
config <- asks getConfig
let m0 = unEnvOverride menv0
path0 = Map.lookup "PATH" m0
path = augmentPath paths 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
when (soptsSanityCheck sopts) $ sanityCheck menv
return mpaths
where
expected = soptsExpected sopts
-- | 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
-> m ()
upgradeCabal menv = 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
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)
ghcPath <- join $ findExecutable menv "ghc"
newestDir <- parseRelDir $ versionString newest
let installRoot = toFilePath $ parent (parent ghcPath)
</> $(mkRelDir "new-cabal")
</> newestDir
dir <-
case Map.lookup ident m of
Nothing -> error $ "upgradeCabal: Invariant violated, dir missing"
Just dir -> return dir
runIn dir "ghc" menv ["Setup.hs"] Nothing
let setupExe = toFilePath $ dir </> $(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"
-- | Get the major version of the system GHC, if available
getSystemGHC :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Maybe (Version, Arch))
getSystemGHC menv = do
exists <- doesExecutableExist menv "ghc"
if exists
then do
eres <- tryProcessStdout Nothing menv "ghc" ["--info"]
return $ 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 (/= '-')
Just (version, arch)
else return Nothing
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
, downloadInfoContentLength :: Int
, downloadInfoSha1 :: Maybe ByteString
}
deriving Show
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
deriving Show
parseDownloadInfoFromObject :: Yaml.Object -> Yaml.Parser DownloadInfo
parseDownloadInfoFromObject o = do
url <- o .: "url"
contentLength <- o .: "content-length"
sha1TextMay <- o .:? "sha1"
return DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
, downloadInfoSha1 = fmap T.encodeUtf8 sha1TextMay
}
instance FromJSON DownloadInfo where
parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject
instance FromJSON VersionedDownloadInfo where
parseJSON = withObject "VersionedDownloadInfo" $ \o -> do
version <- o .: "version"
downloadInfo <- parseDownloadInfoFromObject o
return VersionedDownloadInfo
{ vdiVersion = version
, vdiDownloadInfo = downloadInfo
}
data SetupInfo = SetupInfo
{ siSevenzExe :: DownloadInfo
, siSevenzDll :: DownloadInfo
, siPortableGit :: VersionedDownloadInfo
, siGHCs :: Map Text (Map MajorVersion VersionedDownloadInfo)
}
deriving Show
instance FromJSON SetupInfo where
parseJSON = withObject "SetupInfo" $ \o -> SetupInfo
<$> o .: "sevenzexe-info"
<*> o .: "sevenzdll-info"
<*> o .: "portable-git"
<*> o .: "ghc"
-- | Download the most recent SetupInfo
getSetupInfo :: (MonadIO m, MonadThrow m) => Manager -> m SetupInfo
getSetupInfo manager = do
bss <- liftIO $ flip runReaderT manager
$ withResponse req $ \res -> responseBody res $$ CL.consume
let bs = S8.concat bss
either throwM return $ Yaml.decodeEither' bs
where
req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup.yaml"
markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)
=> PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1
-> 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
-- | Binary directories for the given installed package
binDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)
=> PackageIdentifier
-> m [Path Abs Dir]
binDirs ident = do
config <- asks getConfig
dir <- installDir ident
case (configPlatform config, packageNameString $ packageIdentifierName ident) of
(Platform _ (isWindows -> True), "ghc") -> return
[ dir </> $(mkRelDir "bin")
, dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")
]
(Platform _ (isWindows -> True), "git") -> return
[ dir </> $(mkRelDir "cmd")
, dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")
]
(_, "ghc") -> return
[ dir </> $(mkRelDir "bin")
]
(Platform _ x, tool) -> do
$logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool))
return []
ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> EnvOverride
-> SetupOpts
-> [PackageIdentifier] -- ^ already installed
-> m SetupInfo
-> Maybe (Version, Arch) -- ^ installed GHC
-> (PackageName, Maybe Version)
-> m (Maybe PackageIdentifier)
ensureTool menv sopts installed getSetupInfo' msystem (name, mversion)
| not $ null available = return $ Just $ PackageIdentifier name $ maximum available
| not $ soptsInstallIfMissing sopts =
if name == $(mkPackageName "ghc")
then do
Platform arch _ <- asks getPlatform
throwM $ GHCVersionMismatch msystem (soptsExpected sopts, arch) (soptsStackYaml sopts)
else do
$logWarn $ "Continuing despite missing tool: " <> T.pack (packageNameString name)
return Nothing
| otherwise = do
si <- getSetupInfo'
(VersionedDownloadInfo version downloadInfo, installer) <-
case packageNameString name of
"git" -> do
let pair = siPortableGit si
return (pair, installGitWindows)
"ghc" -> do
osKey <- getOSKey menv
pairs <-
case Map.lookup osKey $ siGHCs si of
Nothing -> throwM $ UnknownOSKey osKey
Just pairs -> return pairs
version <-
case mversion of
Nothing -> error "invariant violated: ghc must have a version"
Just version -> return version
pair <-
case Map.lookup (getMajorVersion version) pairs of
Nothing -> throwM $ UnknownGHCVersion osKey version (Map.keysSet pairs)
Just pair -> return pair
platform <- asks $ configPlatform . getConfig
let installer =
case platform of
Platform _ os | isWindows os -> installGHCWindows
_ -> installGHCPosix
return (pair, installer)
x -> error $ "Invariant violated: ensureTool on " ++ x
let ident = PackageIdentifier name version
(file, at) <- downloadFromInfo downloadInfo ident
dir <- installDir ident
unmarkInstalled ident
installer si file at dir ident
markInstalled ident
return $ Just ident
where
available
| soptsForceReinstall sopts = []
| otherwise = filter goodVersion
$ map packageIdentifierVersion
$ filter (\pi' -> packageIdentifierName pi' == name) installed
goodVersion =
case mversion of
Nothing -> const True
Just expected -> \actual ->
getMajorVersion expected == getMajorVersion actual &&
actual >= expected
getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> EnvOverride -> m Text
getOSKey menv = do
platform <- asks $ configPlatform . getConfig
case platform of
Platform I386 Linux -> ("linux32" <>) <$> getLinuxSuffix
Platform X86_64 Linux -> ("linux64" <>) <$> getLinuxSuffix
Platform I386 OSX -> return "macosx"
Platform X86_64 OSX -> return "macosx"
Platform I386 FreeBSD -> return "freebsd32"
Platform X86_64 FreeBSD -> return "freebsd64"
Platform I386 OpenBSD -> return "openbsd32"
Platform X86_64 OpenBSD -> return "openbsd64"
Platform I386 Windows -> return "windows32"
Platform X86_64 Windows -> return "windows64"
Platform I386 (OtherOS "windowsintegersimple") -> return "windowsintegersimple32"
Platform X86_64 (OtherOS "windowsintegersimple") -> return "windowsintegersimple64"
Platform arch os -> throwM $ UnsupportedSetupCombo os arch
where
getLinuxSuffix = do
executablePath <- liftIO getExecutablePath
elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]
return $ case elddOut of
Left _ -> ""
Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut then "-gmp4" else ""
hasLineWithFirstWord w =
elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode
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 $ packageIdentifierString ident
$logSticky $ "Unpacking GHC ..."
$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
-- | Check if given processes appear to be present, throwing an exception if
-- missing.
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 _ = 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
config <- asks getConfig
run7z <- setup7z si config
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
])
$logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)
installGitWindows :: (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 ()
installGitWindows si archiveFile archiveType destDir _ = do
case archiveType of
SevenZ -> return ()
_ -> error $ "Git on Windows must be a 7z archive"
config <- asks getConfig
run7z <- setup7z si config
run7z destDir archiveFile
-- | Download 7z as necessary, and get a function for unpacking things.
--
-- Returned function takes an unpack directory and archive.
setup7z :: (MonadReader env m, HasHttpManager env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m)
=> SetupInfo
-> Config
-> m (Path Abs Dir -> Path Abs File -> n ())
setup7z si config = do
chattyDownload "7z.dll" (siSevenzDll si) dll
chattyDownload "7z.exe" (siSevenzExe si) exe
return $ \outdir archive -> liftIO $ do
ec <- rawSystem (toFilePath exe)
[ "x"
, "-o" ++ toFilePath outdir
, "-y"
, toFilePath archive
]
when (ec /= ExitSuccess)
$ error $ "Problem while decompressing " ++ toFilePath archive
where
dir = configLocalPrograms config </> $(mkRelDir "7z")
exe = dir </> $(mkRelFile "7z.exe")
dll = dir </> $(mkRelFile "7z.dll")
chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
=> Text -- ^ label
-> DownloadInfo -- ^ URL, content-length, and sha1
-> Path Abs File -- ^ destination
-> 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 = Just totalSize
, 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
totalSize = 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 $
chattyProgressWithTotal totalSoFar totalSize
-- Note(DanBurton): Total size is now always known in this file.
-- However, printing in the case where it isn't known may still be
-- useful in other parts of the codebase.
-- So I'm just commenting out the code rather than deleting it.
-- case mcontentLength of
-- Nothing -> chattyProgressNoTotal totalSoFar
-- Just 0 -> chattyProgressNoTotal totalSoFar
-- Just total -> chattyProgressWithTotal totalSoFar total
---- Example: ghc: 42.13 KiB downloaded...
--chattyProgressNoTotal totalSoFar =
-- printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
-- (T.unpack label)
-- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
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)
-- | Given a printf format string for the decimal part and a number of
-- bytes, formats the bytes using an appropiate unit and returns the
-- formatted string.
--
-- >>> bytesfmt "%.2" 512368
-- "500.359375 KiB"
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"]
-- Await eagerly (collect with monoidal append),
-- but space out yields by at least the given amount of time.
-- The final yield may come sooner, and may be a superfluous mempty.
-- Note that Integer and Float literals can be turned into NominalDiffTime
-- (these literals are interpreted as "seconds")
chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> Conduit a m a
chunksOverTime diff = do
currentTime <- liftIO getCurrentTime
evalStateC (currentTime, mempty) go
where
-- State is a tuple of:
-- * the last time a yield happened (or the beginning of the sink)
-- * the accumulated awaits since the last yield
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
-- | Perform a basic sanity check of GHC
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" -- ensure Cabal library is present
, "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 () -- TODO check that the output of running the command is correct
toFilePathNoTrailingSlash :: Path loc Dir -> FilePath
toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath
-- Remove potentially confusing environment variables
removeHaskellEnvVars :: Map Text Text -> Map Text Text
removeHaskellEnvVars =
Map.delete "GHC_PACKAGE_PATH" .
Map.delete "HASKELL_PACKAGE_SANDBOX" .
Map.delete "HASKELL_PACKAGE_SANDBOXES" .
Map.delete "HASKELL_DIST_DIR"