hackport-0.2.19: cabal/cabal-install/Distribution/Client/Install.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
-- Copyright : (c) 2005 David Himmelstrup
-- 2007 Bjorn Bringert
-- 2007-2010 Duncan Coutts
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- High level interface to package installation.
-----------------------------------------------------------------------------
module Distribution.Client.Install (
install,
upgrade,
) where
import Data.List
( unfoldr, nub, sort, (\\) )
import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Control.Exception as Exception
( bracket, handleJust )
#if MIN_VERSION_base(4,0,0)
import Control.Exception as Exception
( Exception(toException), catches, Handler(Handler), IOException )
import System.Exit
( ExitCode )
#else
import Control.Exception as Exception
( Exception(IOException, ExitException) )
#endif
import Distribution.Compat.ExceptionCI
( SomeException, catchIO, catchExit )
import Control.Monad
( when, unless )
import System.Directory
( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )
import System.FilePath
( (</>), (<.>), takeDirectory )
import System.IO
( openFile, IOMode(AppendMode), stdout, hFlush, hClose )
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
import Distribution.Client.Targets
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( Solver(..) )
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
-- import qualified Distribution.Client.Info as Info
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
( GlobalFlags(..)
, ConfigFlags(..), configureCommand, filterConfigureFlags
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
( defaultCabalDir )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import qualified Distribution.Client.PackageIndex as SourcePackageIndex
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.Client.World as World
import qualified Distribution.InstalledPackageInfo as Installed
import Paths_cabal_install (getBinDir)
import Distribution.Client.JobControl
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId), compilerFlavor
, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..)
, buildCommand, BuildFlags(..), emptyBuildFlags
, toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.Setup as Cabal
( installCommand, InstallFlags(..), emptyInstallFlags
, emptyTestFlags, testCommand, Flag(..) )
import Distribution.Simple.Utils
( rawSystemExit, comparing )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
( PackageIdentifier, PackageId, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion, InstalledPackageId )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..)
, FlagName(..), FlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Version
( Version, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
( numberOfProcessors, inDir, mergeBy, MergeResult(..) )
import Distribution.System
( Platform, buildPlatform, OS(Windows), buildOS )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
( Verbosity, showForCabal, verbose, deafening )
import Distribution.Simple.BuildPaths ( exeExtension )
--TODO:
-- * assign flags to packages individually
-- * complain about flags that do not apply to any package given as target
-- so flags do not apply to dependencies, only listed, can use flag
-- constraints for dependencies
-- * only record applicable flags in world file
-- * allow flag constraints
-- * allow installed constraints
-- * allow flag and installed preferences
-- * change world file to use cabal section syntax
-- * allow persistent configure flags for each package individually
-- ------------------------------------------------------------
-- * Top level user actions
-- ------------------------------------------------------------
-- | Installs the packages needed to satisfy a list of dependencies.
--
install, upgrade
:: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> [UserTarget]
-> IO ()
install verbosity packageDBs repos comp conf
globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerId comp)
let -- For install, if no target is given it means we use the
-- current directory as the single target
userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
planPackages
comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers
unless dryRun $ do
installPlan' <- performInstallations verbosity
context installedPkgIndex installPlan
postInstallActions verbosity context userTargets installPlan'
where
context :: InstallContext
context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = debugNoWrap message >> rest
-- Solver debug output really looks better without automatic
-- line wrapping. TODO: This should probably be moved into
-- the utilities module.
debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout)
upgrade _ _ _ _ _ _ _ _ _ _ _ = die $
"Use the 'cabal install' command instead of 'cabal upgrade'.\n"
++ "You can install the latest version of a package using 'cabal install'. "
++ "The 'cabal upgrade' command has been removed because people found it "
++ "confusing and it often led to broken packages.\n"
++ "If you want the old upgrade behaviour then use the install command "
++ "with the --upgrade-dependencies flag (but check first with --dry-run "
++ "to see what would happen). This will try to pick the latest versions "
++ "of all dependencies, rather than the usual behaviour of trying to pick "
++ "installed versions of all dependencies. If you do use "
++ "--upgrade-dependencies, it is recommended that you do not upgrade core "
++ "packages (e.g. by using appropriate --constraint= flags)."
type InstallContext = ( PackageDBStack
, [Repo]
, Compiler
, ProgramConfiguration
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags )
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
planPackages :: Compiler
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> Progress String String InstallPlan
planPackages comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers =
resolveDependencies
buildPlatform (compilerId comp)
solver
resolverParams
>>= if onlyDeps then adjustPlanOnlyDeps else return
where
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
else Just maxBackjumps)
. setIndependentGoals independentGoals
. setReorderGoals reorderGoals
. setAvoidReinstalls avoidReinstalls
. setShadowPkgs shadowPkgs
. setPreferenceDefault (if upgradeDeps then PreferAllLatest
else PreferLatestForSelected)
. addPreferences
-- preferences from the config file or command line
[ PackageVersionPreference name ver
| Dependency name ver <- configPreferences configExFlags ]
. addConstraints
-- version constraints from the config file or command line
(map userToPackageConstraint (configExConstraints configExFlags))
. addConstraints
--FIXME: this just applies all flags to all targets which
-- is silly. We should check if the flags are appropriate
[ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
| let flags = configConfigurationsFlags configFlags
, not (null flags)
, pkgSpecifier <- pkgSpecifiers ]
. addConstraints
[ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas
| pkgSpecifier <- pkgSpecifiers ]
. (if reinstall then reinstallTargets else id)
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
stanzas = concat
[ if testsEnabled then [TestStanzas] else []
, if benchmarksEnabled then [BenchStanzas] else []
]
testsEnabled = fromFlagOrDefault False $ configTests configFlags
benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
--TODO: this is a general feature and should be moved to D.C.Dependency
-- Also, the InstallPlan.remove should return info more precise to the
-- problem, rather than the very general PlanProblem type.
adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan
adjustPlanOnlyDeps =
either (Fail . explain) Done
. InstallPlan.remove (isTarget pkgSpecifiers)
where
explain :: [InstallPlan.PlanProblem] -> String
explain problems =
"Cannot select only the dependencies (as requested by the "
++ "'--only-dependencies' flag), "
++ (case pkgids of
[pkgid] -> "the package " ++ display pkgid ++ " is "
_ -> "the packages "
++ intercalate ", " (map display pkgids) ++ " are ")
++ "required by a dependency of one of the other targets."
where
pkgids =
nub [ depid
| InstallPlan.PackageMissingDeps _ depids <- problems
, depid <- depids
, packageName depid `elem` targetnames ]
targetnames = map pkgSpecifierTarget pkgSpecifiers
reinstall = fromFlag (installReinstall installFlags)
reorderGoals = fromFlag (installReorderGoals installFlags)
independentGoals = fromFlag (installIndependentGoals installFlags)
avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)
shadowPkgs = fromFlag (installShadowPkgs installFlags)
maxBackjumps = fromFlag (installMaxBackjumps installFlags)
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
onlyDeps = fromFlag (installOnlyDeps installFlags)
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
checkPrintPlan :: Verbosity
-> PackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier SourcePackage]
-> IO ()
checkPrintPlan verbosity installed installPlan sourcePkgDb
installFlags pkgSpecifiers = do
-- User targets that are already installed.
let preExistingTargets =
[ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,
InstallPlan.PreExisting p <- InstallPlan.toList installPlan,
packageName p `elem` tgts ]
-- If there's nothing to install, we print the already existing
-- target packages as an explanation.
when nothingToInstall $
notice verbosity $ unlines $
"All the requested packages are already installed:"
: map (display . packageId) preExistingTargets
++ ["Use --reinstall if you want to reinstall anyway."]
let lPlan = linearizeInstallPlan installed installPlan
-- Are any packages classified as reinstalls?
let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
-- Packages that are already broken.
let oldBrokenPkgs =
map Installed.installedPackageId
. PackageIndex.reverseDependencyClosure installed
. map (Installed.installedPackageId . fst)
. PackageIndex.brokenPackages
$ installed
let excluded = reinstalledPkgs ++ oldBrokenPkgs
-- Packages that are reverse dependencies of replaced packages are very
-- likely to be broken. We exclude packages that are already broken.
let newBrokenPkgs =
filter (\ p -> not (Installed.installedPackageId p `elem` excluded))
(PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
let containsReinstalls = not (null reinstalledPkgs)
let breaksPkgs = not (null newBrokenPkgs)
let adaptedVerbosity
| containsReinstalls && not overrideReinstall = verbosity `max` verbose
| otherwise = verbosity
-- We print the install plan if we are in a dry-run or if we are confronted
-- with a dangerous install plan.
when (dryRun || containsReinstalls && not overrideReinstall) $
printPlan (dryRun || breaksPkgs && not overrideReinstall)
adaptedVerbosity lPlan sourcePkgDb
-- If the install plan is dangerous, we print various warning messages. In
-- particular, if we can see that packages are likely to be broken, we even
-- bail out (unless installation has been forced with --force-reinstalls).
when containsReinstalls $ do
if breaksPkgs
then do
(if dryRun || overrideReinstall then warn verbosity else die) $ unlines $
"The following packages are likely to be broken by the reinstalls:"
: map (display . Installed.sourcePackageId) newBrokenPkgs
++ if overrideReinstall
then if dryRun then [] else
["Continuing even though the plan contains dangerous reinstalls."]
else
["Use --force-reinstalls if you want to install anyway."]
else unless dryRun $ warn verbosity
"Note that reinstalls are always dangerous. Continuing anyway..."
where
nothingToInstall = null (InstallPlan.ready installPlan)
dryRun = fromFlag (installDryRun installFlags)
overrideReinstall = fromFlag (installOverrideReinstall installFlags)
linearizeInstallPlan :: PackageIndex
-> InstallPlan
-> [(ConfiguredPackage, PackageStatus)]
linearizeInstallPlan installedPkgIndex plan =
unfoldr next plan
where
next plan' = case InstallPlan.ready plan' of
[] -> Nothing
(pkg:_) -> Just ((pkg, status), plan'')
where
pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
plan'' = InstallPlan.completed pkgid
(BuildOk DocsNotTried TestsNotTried)
(InstallPlan.processing [pkg] plan')
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
data PackageStatus = NewPackage
| NewVersion [Version]
| Reinstall [InstalledPackageId] [PackageChange]
type PackageChange = MergeResult PackageIdentifier PackageIdentifier
isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool
isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames
where
targetnames = map pkgSpecifierTarget pkgSpecifiers
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _ = []
packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus
packageStatus installedPkgIndex cpkg =
case PackageIndex.lookupPackageName installedPkgIndex
(packageName cpkg) of
[] -> NewPackage
ps -> case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of
[] -> NewVersion (map fst ps)
pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
(changes pkg cpkg)
where
changes :: Installed.InstalledPackageInfo
-> ConfiguredPackage
-> [MergeResult PackageIdentifier PackageIdentifier]
changes pkg pkg' = filter changed
$ mergeBy (comparing packageName)
-- get dependencies of installed package (convert to source pkg ids via index)
(nub . sort . concatMap (maybeToList .
fmap Installed.sourcePackageId .
PackageIndex.lookupInstalledPackageId installedPkgIndex) .
Installed.depends $ pkg)
-- get dependencies of configured package
(nub . sort . depends $ pkg')
changed (InBoth pkgid pkgid') = pkgid /= pkgid'
changed _ = True
printPlan :: Bool -- is dry run
-> Verbosity
-> [(ConfiguredPackage, PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan dryRun verbosity plan sourcePkgDb = case plan of
[] -> return ()
pkgs
| verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
("In order, the following " ++ wouldWill ++ " be installed:")
: map showPkgAndReason pkgs
| otherwise -> notice verbosity $ unlines $
("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):")
: map showPkg pkgs
where
wouldWill | dryRun = "would"
| otherwise = "will"
showPkg (pkg, _) = display (packageId pkg) ++
showLatest (pkg)
showPkgAndReason (pkg', pr) = display (packageId pkg') ++
showLatest pkg' ++
showFlagAssignment (nonDefaultFlags pkg') ++
showStanzas (stanzas pkg') ++ " " ++
case pr of
NewPackage -> "(new package)"
NewVersion _ -> "(new version)"
Reinstall _ cs -> "(reinstall)" ++ case cs of
[] -> ""
diff -> " changes: " ++ intercalate ", " (map change diff)
showLatest :: ConfiguredPackage -> String
showLatest pkg = case mLatestVersion of
Just latestVersion ->
if pkgVersion /= latestVersion
then (" (latest: " ++ display latestVersion ++ ")")
else ""
Nothing -> ""
where
pkgVersion = packageVersion pkg
mLatestVersion :: Maybe Version
mLatestVersion = case SourcePackageIndex.lookupPackageName
(packageIndex sourcePkgDb)
(packageName pkg) of
[] -> Nothing
x -> Just $ packageVersion $ last x
toFlagAssignment :: [Flag] -> FlagAssignment
toFlagAssignment = map (\ f -> (flagName f, flagDefault f))
nonDefaultFlags :: ConfiguredPackage -> FlagAssignment
nonDefaultFlags (ConfiguredPackage spkg fa _ _) =
let defaultAssignment =
toFlagAssignment
(genPackageFlags (Source.packageDescription spkg))
in fa \\ defaultAssignment
stanzas :: ConfiguredPackage -> [OptionalStanza]
stanzas (ConfiguredPackage _ _ sts _) = sts
showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((' ' :) . showStanza)
showStanza TestStanzas = "*test"
showStanza BenchStanzas = "*bench"
-- FIXME: this should be a proper function in a proper place
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagValue (f, True) = '+' : showFlagName f
showFlagValue (f, False) = '-' : showFlagName f
showFlagName (FlagName f) = f
change (OnlyInLeft pkgid) = display pkgid ++ " removed"
change (InBoth pkgid pkgid') = display pkgid ++ " -> "
++ display (packageVersion pkgid')
change (OnlyInRight pkgid') = display pkgid' ++ " added"
-- ------------------------------------------------------------
-- * Post installation stuff
-- ------------------------------------------------------------
-- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes:
--
-- * build reporting, local and remote
-- * symlinking binaries
-- * updating indexes
-- * updating world file
-- * error reporting
--
postInstallActions :: Verbosity
-> InstallContext
-> [UserTarget]
-> InstallPlan
-> IO ()
postInstallActions verbosity
(packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _)
targets installPlan = do
unless oneShot $
World.insert verbosity worldFile
--FIXME: does not handle flags
[ World.WorldPkgInfo dep []
| UserTargetNamed dep <- targets ]
let buildReports = BuildReports.fromInstallPlan installPlan
BuildReports.storeLocal (installSummaryFile installFlags) buildReports
when (reportingLevel >= AnonymousReports) $
BuildReports.storeAnonymous buildReports
when (reportingLevel == DetailedReports) $
storeDetailedBuildReports verbosity logsDir buildReports
regenerateHaddockIndex verbosity packageDBs comp conf
configFlags installFlags installPlan
symlinkBinaries verbosity configFlags installFlags installPlan
printBuildFailures installPlan
where
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
oneShot = fromFlag (installOneShot installFlags)
worldFile = fromFlag $ globalWorldFile globalFlags
storeDetailedBuildReports :: Verbosity -> FilePath
-> [(BuildReports.BuildReport, Repo)] -> IO ()
storeDetailedBuildReports verbosity logsDir reports = sequence_
[ do dotCabal <- defaultCabalDir
let logFileName = display (BuildReports.package report) <.> "log"
logFile = logsDir </> logFileName
reportsDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
reportFile = reportsDir </> logFileName
handleMissingLogFile $ do
buildLog <- readFile logFile
createDirectoryIfMissing True reportsDir -- FIXME
writeFile reportFile (show (BuildReports.show report, buildLog))
| (report, Repo { repoKind = Left remoteRepo }) <- reports
, isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
where
isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True
isLikelyToHaveLogFile BuildReports.BuildFailed {} = True
isLikelyToHaveLogFile BuildReports.InstallFailed {} = True
isLikelyToHaveLogFile BuildReports.InstallOk {} = True
isLikelyToHaveLogFile _ = False
handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->
warn verbosity $ "Missing log file for build report: "
++ fromMaybe "" (ioeGetFileName ioe)
#if MIN_VERSION_base(4,0,0)
missingFile ioe
#else
missingFile (IOException ioe)
#endif
| isDoesNotExistError ioe = Just ioe
missingFile _ = Nothing
regenerateHaddockIndex :: Verbosity
-> [PackageDB]
-> Compiler
-> ProgramConfiguration
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> IO ()
regenerateHaddockIndex verbosity packageDBs comp conf
configFlags installFlags installPlan
| haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do
defaultDirs <- InstallDirs.defaultInstallDirs
(compilerFlavor comp)
(fromFlag (configUserInstall configFlags))
True
let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
notice verbosity $
"Updating documentation index " ++ indexFile
--TODO: might be nice if the install plan gave us the new InstalledPackageInfo
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
| otherwise = return ()
where
haddockIndexFileIsRequested =
fromFlag (installDocumentation installFlags)
&& isJust (flagToMaybe (installHaddockIndex installFlags))
-- We want to regenerate the index if some new documentation was actually
-- installed. Since the index is per-user, we don't do it for global
-- installs or special cases where we're installing into a specific db.
shouldRegenerateHaddockIndex = normalUserInstall
&& someDocsWereInstalled installPlan
where
someDocsWereInstalled = any installedDocs . InstallPlan.toList
normalUserInstall = (UserPackageDB `elem` packageDBs)
&& all (not . isSpecificPackageDB) packageDBs
installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True
installedDocs _ = False
isSpecificPackageDB (SpecificPackageDB _) = True
isSpecificPackageDB _ = False
substHaddockIndexFileName defaultDirs = fromPathTemplate
. substPathTemplate env
where
env = env0 ++ installDirsTemplateEnv absoluteDirs
env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
++ InstallDirs.platformTemplateEnv (buildPlatform)
absoluteDirs = InstallDirs.substituteInstallDirTemplates
env0 templateDirs
templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
defaultDirs (configInstallDirs configFlags)
symlinkBinaries :: Verbosity
-> ConfigFlags
-> InstallFlags
-> InstallPlan -> IO ()
symlinkBinaries verbosity configFlags installFlags plan = do
failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan
case failed of
[] -> return ()
[(_, exe, path)] ->
warn verbosity $
"could not create a symlink in " ++ bindir ++ " for "
++ exe ++ " because the file exists there already but is not "
++ "managed by cabal. You can create a symlink for this executable "
++ "manually if you wish. The executable file has been installed at "
++ path
exes ->
warn verbosity $
"could not create symlinks in " ++ bindir ++ " for "
++ intercalate ", " [ exe | (_, exe, _) <- exes ]
++ " because the files exist there already and are not "
++ "managed by cabal. You can create symlinks for these executables "
++ "manually if you wish. The executable files have been installed at "
++ intercalate ", " [ path | (_, _, path) <- exes ]
where
bindir = fromFlag (installSymlinkBinDir installFlags)
printBuildFailures :: InstallPlan -> IO ()
printBuildFailures plan =
case [ (pkg, reason)
| InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of
[] -> return ()
failed -> die . unlines
$ "Error: some packages failed to install:"
: [ display (packageId pkg) ++ printFailureReason reason
| (pkg, reason) <- failed ]
where
printFailureReason reason = case reason of
DependentFailed pkgid -> " depends on " ++ display pkgid
++ " which failed to install."
DownloadFailed e -> " failed while downloading the package."
++ " The exception was:\n " ++ show e
UnpackFailed e -> " failed while unpacking the package."
++ " The exception was:\n " ++ show e
ConfigureFailed e -> " failed during the configure step."
++ " The exception was:\n " ++ show e
BuildFailed e -> " failed during the building phase."
++ " The exception was:\n " ++ show e
TestsFailed e -> " failed during the tests phase."
++ " The exception was:\n " ++ show e
InstallFailed e -> " failed during the final install step."
++ " The exception was:\n " ++ show e
-- ------------------------------------------------------------
-- * Actually do the installations
-- ------------------------------------------------------------
data InstallMisc = InstallMisc {
rootCmd :: Maybe FilePath,
libVersion :: Maybe Version
}
-- | If logging is enabled, contains location of the log file and the verbosity
-- level for logging.
type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)
performInstallations :: Verbosity
-> InstallContext
-> PackageIndex
-> InstallPlan
-> IO InstallPlan
performInstallations verbosity
(packageDBs, _, comp, conf,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
jobControl <- if parallelBuild then newParallelJobControl
else newSerialJobControl
buildLimit <- newJobLimit numJobs
fetchLimit <- newJobLimit (min numJobs numFetchJobs)
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity buildLimit installLock numJobs
(setupScriptOptions installedPkgIndex cacheLock)
miscOptions configFlags' installFlags haddockFlags
compid pkg mpath useLogFile
where
platform = InstallPlan.planPlatform installPlan
compid = InstallPlan.planCompiler installPlan
numJobs = case installNumJobs installFlags of
Cabal.NoFlag -> 1
Cabal.Flag Nothing -> numberOfProcessors
Cabal.Flag (Just n) -> n
numFetchJobs = 2
parallelBuild = numJobs >= 2
setupScriptOptions index lock = SetupScriptOptions {
useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),
useCompiler = Just comp,
-- Hack: we typically want to allow the UserPackageDB for finding the
-- Cabal lib when compiling any Setup.hs even if we're doing a global
-- install. However we also allow looking in a specific package db.
usePackageDB = if UserPackageDB `elem` packageDBs
then packageDBs
else let (db@GlobalPackageDB:dbs) = packageDBs
in db : UserPackageDB : dbs,
--TODO: use Ord instance:
-- insert UserPackageDB packageDBs
usePackageIndex = if UserPackageDB `elem` packageDBs
then Just index
else Nothing,
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags),
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = parallelBuild,
setupCacheLock = Just lock
}
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
-- Should the build output be written to a log file instead of stdout?
useLogFile :: UseLogFile
useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)
logFileTemplate
where
installLogFile' = flagToMaybe $ installLogFile installFlags
defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"
-- If the user has specified --remote-build-reporting=detailed, use the
-- default log file location. If the --build-log option is set, use the
-- provided location. Otherwise don't use logging, unless building in
-- parallel (in which case the default location is used).
logFileTemplate :: Maybe PathTemplate
logFileTemplate
| useDefaultTemplate = Just defaultTemplate
| otherwise = installLogFile'
-- If the user has specified --remote-build-reporting=detailed or
-- --build-log, use more verbose logging.
loggingVerbosity :: Verbosity
loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity
| otherwise = verbosity
useDefaultTemplate :: Bool
useDefaultTemplate
| reportingLevel == DetailedReports = True
| isJust installLogFile' = False
| parallelBuild = True
| otherwise = False
overrideVerbosity :: Bool
overrideVerbosity
| reportingLevel == DetailedReports = True
| isJust installLogFile' = True
| parallelBuild = False
| otherwise = False
substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath
substLogFileName template pkg = fromPathTemplate
. substPathTemplate env
$ template
where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)
miscOptions = InstallMisc {
rootCmd = if fromFlag (configUserInstall configFlags)
then Nothing -- ignore --root-cmd if --user.
else flagToMaybe (installRootCmd installFlags),
libVersion = flagToMaybe (configCabalVersion configExFlags)
}
executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> UseLogFile
-> InstallPlan
-> (ConfiguredPackage -> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
tryNewTasks 0 plan0
where
tryNewTasks taskCount plan = do
case InstallPlan.ready plan of
[] | taskCount == 0 -> return plan
| otherwise -> waitForTasks taskCount plan
pkgs -> do
sequence_
[ do info verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg
return (packageId pkg, buildResult)
| pkg <- pkgs
, let pkgid = packageId pkg]
let taskCount' = taskCount + length pkgs
plan' = InstallPlan.processing pkgs plan
waitForTasks taskCount' plan'
waitForTasks taskCount plan = do
info verbosity $ "Waiting for install task to finish..."
(pkgid, buildResult) <- collectJob jobCtl
printBuildResult pkgid buildResult
let taskCount' = taskCount-1
plan' = updatePlan pkgid buildResult plan
tryNewTasks taskCount' plan'
updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan
updatePlan pkgid (Right buildSuccess) =
InstallPlan.completed pkgid buildSuccess
updatePlan pkgid (Left buildFailure) =
InstallPlan.failed pkgid buildFailure depsFailure
where
depsFailure = DependentFailed pkgid
-- So this first pkgid failed for whatever reason (buildFailure).
-- All the other packages that depended on this pkgid, which we
-- now cannot build, we mark as failing due to 'DependentFailed'
-- which kind of means it was not their fault.
-- Print last 10 lines of the build log if something went wrong, and
-- 'Installed $PKGID' otherwise.
printBuildResult :: PackageId -> BuildResult -> IO ()
printBuildResult pkgid buildResult = case buildResult of
(Right _) -> notice verbosity $ "Installed " ++ display pkgid
(Left _) -> do
notice verbosity $ "Failed to install " ++ display pkgid
case useLogFile of
Nothing -> return ()
Just (mkLogFileName, _) -> do
let (logName, n) = (mkLogFileName pkgid, 10)
notice verbosity $ "Last " ++ (show n)
++ " lines of the build log ( " ++ logName ++ " ):"
printLastNLines logName n
printLastNLines :: FilePath -> Int -> IO ()
printLastNLines path n = do
lns <- fmap lines $ readFile path
let len = length lns
let toDrop = if len > n && n > 0 then (len - n) else 0
mapM_ (notice verbosity) (drop toDrop lns)
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
installConfiguredPackage :: Platform -> CompilerId
-> ConfigFlags -> ConfiguredPackage
-> (ConfigFlags -> PackageLocation (Maybe FilePath)
-> PackageDescription -> a)
-> a
installConfiguredPackage platform comp configFlags
(ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps)
installPkg = installPkg configFlags {
configConfigurationsFlags = flags,
configConstraints = map thisPackageVersion deps,
configBenchmarks = toFlag False,
configTests = toFlag (TestStanzas `elem` stanzas)
} source pkg
where
pkg = case finalizePackageDescription flags
(const True)
platform comp [] (enableStanzas stanzas gpkg) of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Right (desc, _) -> desc
fetchSourcePackage
:: Verbosity
-> JobLimit
-> PackageLocation (Maybe FilePath)
-> (PackageLocation FilePath -> IO BuildResult)
-> IO BuildResult
fetchSourcePackage verbosity fetchLimit src installPkg = do
fetched <- checkFetched src
case fetched of
Just src' -> installPkg src'
Nothing -> onFailure DownloadFailed $ do
loc <- withJobLimit fetchLimit $
fetchPackage verbosity src
installPkg loc
installLocalPackage
:: Verbosity
-> JobLimit
-> PackageIdentifier -> PackageLocation FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
installLocalPackage verbosity jobLimit pkgid location installPkg =
case location of
LocalUnpackedPackage dir ->
installPkg (Just dir)
LocalTarballPackage tarballPath ->
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
RemoteTarballPackage _ tarballPath ->
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
RepoTarballPackage _ _ tarballPath ->
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
installLocalTarballPackage
:: Verbosity
-> JobLimit
-> PackageIdentifier -> FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do
tmp <- getTemporaryDirectory
withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
onFailure UnpackFailed $ do
let relUnpackedPath = display pkgid
absUnpackedPath = tmpDirPath </> relUnpackedPath
descFilePath = absUnpackedPath
</> display (packageName pkgid) <.> "cabal"
withJobLimit jobLimit $ do
info verbosity $ "Extracting " ++ tarballPath
++ " to " ++ tmpDirPath ++ "..."
extractTarGzFile tmpDirPath relUnpackedPath tarballPath
exists <- doesFileExist descFilePath
when (not exists) $
die $ "Package .cabal file not found: " ++ show descFilePath
installPkg (Just absUnpackedPath)
installUnpackedPackage
:: Verbosity
-> JobLimit
-> Lock
-> Int
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> UseLogFile -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity buildLimit installLock numJobs
scriptOptions miscOptions
configFlags installConfigFlags haddockFlags
compid pkg workingDir useLogFile =
-- Configure phase
onFailure ConfigureFailed $ withJobLimit buildLimit $ do
when (numJobs > 1) $ notice verbosity $
"Configuring " ++ display pkgid ++ "..."
setup configureCommand configureFlags
-- Build phase
onFailure BuildFailed $ do
when (numJobs > 1) $ notice verbosity $
"Building " ++ display pkgid ++ "..."
setup buildCommand' buildFlags
-- Doc generation phase
docsResult <- if shouldHaddock
then (do setup haddockCommand haddockFlags'
return DocsOk)
`catchIO` (\_ -> return DocsFailed)
`catchExit` (\_ -> return DocsFailed)
else return DocsNotTried
-- Tests phase
onFailure TestsFailed $ do
when (testsEnabled && PackageDescription.hasTests pkg) $
setup Cabal.testCommand testFlags
let testsResult | testsEnabled = TestsOk
| otherwise = TestsNotTried
-- Install phase
onFailure InstallFailed $ criticalSection installLock $
withWin32SelfUpgrade verbosity configFlags compid pkg $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
Nothing -> setup Cabal.installCommand installFlags
return (Right (BuildOk docsResult testsResult))
where
pkgid = packageId pkg
configureFlags = filterConfigureFlags configFlags {
configVerbosity = toFlag verbosity'
}
buildCommand' = buildCommand defaultProgramConfiguration
buildFlags _ = emptyBuildFlags {
buildDistPref = configDistPref configFlags,
buildVerbosity = toFlag verbosity'
}
shouldHaddock = fromFlag (installDocumentation installConfigFlags)
haddockFlags' _ = haddockFlags {
haddockVerbosity = toFlag verbosity'
}
testsEnabled = fromFlag (configTests configFlags)
testFlags _ = Cabal.emptyTestFlags
installFlags _ = Cabal.emptyInstallFlags {
Cabal.installDistPref = configDistPref configFlags,
Cabal.installVerbosity = toFlag verbosity'
}
verbosity' = maybe verbosity snd useLogFile
setup cmd flags = do
Exception.bracket
(case useLogFile of
Nothing -> return Nothing
Just (mkLogFileName, _) -> do
let logFileName = mkLogFileName (packageId pkg)
logDir = takeDirectory logFileName
unless (null logDir) $ createDirectoryIfMissing True logDir
logFile <- openFile logFileName AppendMode
return (Just logFile))
(\mHandle -> case mHandle of
Just handle -> hClose handle
Nothing -> return ())
(\logFileHandle ->
setupWrapper verbosity
scriptOptions { useLoggingHandle = logFileHandle
, useWorkingDir = workingDir }
(Just pkg)
cmd flags [])
reexec cmd = do
-- look for our on executable file and re-exec ourselves using
-- a helper program like sudo to elevate priviledges:
bindir <- getBinDir
let self = bindir </> "cabal" <.> exeExtension
weExist <- doesFileExist self
if weExist
then inDir workingDir $
rawSystemExit verbosity cmd
[self, "install", "--only"
,"--verbose=" ++ showForCabal verbosity]
else die $ "Unable to find cabal executable at: " ++ self
-- helper
onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult
onFailure result action =
#if MIN_VERSION_base(4,0,0)
action `catches`
[ Handler $ \ioe -> handler (ioe :: IOException)
, Handler $ \exit -> handler (exit :: ExitCode)
]
where
handler :: Exception e => e -> IO BuildResult
handler = return . Left . result . toException
#else
action
`catchIO` (return . Left . result . IOException)
`catchExit` (return . Left . result . ExitException)
#endif
-- ------------------------------------------------------------
-- * Wierd windows hacks
-- ------------------------------------------------------------
withWin32SelfUpgrade :: Verbosity
-> ConfigFlags
-> CompilerId
-> PackageDescription
-> IO a -> IO a
withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action
withWin32SelfUpgrade verbosity configFlags compid pkg action = do
defaultDirs <- InstallDirs.defaultInstallDirs
compFlavor
(fromFlag (configUserInstall configFlags))
(PackageDescription.hasLibs pkg)
Win32SelfUpgrade.possibleSelfUpgrade verbosity
(exeInstallPaths defaultDirs) action
where
pkgid = packageId pkg
(CompilerId compFlavor _) = compid
exeInstallPaths defaultDirs =
[ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension
| exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe)
, let exeName = prefix ++ PackageDescription.exeName exe ++ suffix
prefix = substTemplate prefixTemplate
suffix = substTemplate suffixTemplate ]
where
fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
defaultDirs (configInstallDirs configFlags)
absoluteDirs = InstallDirs.absoluteInstallDirs
pkgid compid InstallDirs.NoCopyDest templateDirs
substTemplate = InstallDirs.fromPathTemplate
. InstallDirs.substPathTemplate env
where env = InstallDirs.initialPathTemplateEnv pkgid compid