cabal-install-0.8.2: Distribution/Client/Install.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- High level interface to package installation.
-----------------------------------------------------------------------------
module Distribution.Client.Install (
install,
upgrade,
) where
import Data.List
( unfoldr, find, nub, sort )
import Data.Maybe
( isJust, fromMaybe )
import qualified Data.Map as Map
import Control.Exception as Exception
( 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.Exception
( SomeException, catchIO, catchExit )
import Control.Monad
( when, unless )
import System.Directory
( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )
import System.FilePath
( (</>), (<.>), takeDirectory )
import System.IO
( openFile, IOMode(AppendMode) )
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
import Distribution.Client.Dependency
( resolveDependenciesWithProgress
, PackageConstraint(..), dependencyConstraints, dependencyTargets
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..)
, upgradableDependencies
, Progress(..), foldProgress, )
import Distribution.Client.Fetch (fetchPackage)
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
-- import qualified Distribution.Client.Info as Info
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies
, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
( ConfigFlags(..), configureCommand, filterConfigureFlags
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
( defaultLogsDir, defaultCabalDir )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Available
( UnresolvedDependency(..), AvailablePackage(..)
, AvailablePackageSource(..), AvailablePackageDb(..)
, Repo(..), ConfiguredPackage(..)
, BuildResult, BuildFailure(..), BuildSuccess(..)
, DocsResult(..), TestsResult(..), RemoteRepo(..)
, InstalledPackage )
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.Win32SelfUpgrade as Win32SelfUpgrade
import Paths_cabal_install (getBinDir)
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.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..), emptyHaddockFlags
, buildCommand, BuildFlags(..), emptyBuildFlags
, toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.Setup as Cabal
( installCommand, InstallFlags(..), emptyInstallFlags )
import Distribution.Simple.Utils
( defaultPackageDesc, rawSystemExit, comparing )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
( PackageName, PackageIdentifier, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Version
( Version, VersionRange, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
( inDir, mergeBy, MergeResult(..) )
import Distribution.System
( Platform, buildPlatform, OS(Windows), buildOS )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
( Verbosity, showForCabal, verbose )
import Distribution.Simple.BuildPaths ( exeExtension )
data InstallMisc = InstallMisc {
rootCmd :: Maybe FilePath,
libVersion :: Maybe Version
}
-- |Installs the packages needed to satisfy a list of dependencies.
install, upgrade
:: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> [UnresolvedDependency]
-> IO ()
install verbosity packageDB repos comp conf
configFlags configExFlags installFlags deps =
installWithPlanner planner
verbosity packageDB repos comp conf
configFlags configExFlags installFlags
where
planner :: Planner
planner | null deps = planLocalPackage verbosity
comp configFlags configExFlags
| otherwise = planRepoPackages PreferLatestForSelected
comp configFlags configExFlags installFlags deps
upgrade verbosity packageDB repos comp conf
configFlags configExFlags installFlags deps =
installWithPlanner planner
verbosity packageDB repos comp conf
configFlags configExFlags installFlags
where
planner :: Planner
planner | null deps = planUpgradePackages
comp configFlags configExFlags
| otherwise = planRepoPackages PreferAllLatest
comp configFlags configExFlags installFlags deps
type Planner = Maybe (PackageIndex InstalledPackage)
-> AvailablePackageDb
-> IO (Progress String String InstallPlan)
-- |Installs the packages generated by a planner.
installWithPlanner ::
Planner
-> Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> IO ()
installWithPlanner planner verbosity packageDBs repos comp conf
configFlags configExFlags installFlags = do
installed <- getInstalledPackages verbosity comp packageDBs conf
available <- getAvailablePackages verbosity repos
progress <- planner installed available
notice verbosity "Resolving dependencies..."
maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)
(return . Left) (return . Right) progress
case maybePlan of
Left message -> die message
Right installPlan -> do
let nothingToInstall = null (InstallPlan.ready installPlan)
when nothingToInstall $
notice verbosity $
"No packages to be installed. All the requested packages are "
++ "already installed.\n If you want to reinstall anyway then use "
++ "the --reinstall flag."
when (dryRun || verbosity >= verbose) $
printDryRun verbosity installed installPlan
unless dryRun $ do
logsDir <- defaultLogsDir
let platform = InstallPlan.planPlatform installPlan
compid = InstallPlan.planCompiler installPlan
installPlan' <-
executeInstallPlan installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
installAvailablePackage verbosity (packageId pkg) src $ \mpath ->
installUnpackedPackage verbosity (setupScriptOptions installed)
miscOptions configFlags' installFlags
compid pkg mpath (useLogFile logsDir)
-- build reporting, local and remote
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
setupScriptOptions index = 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 index
else Nothing,
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags),
useLoggingHandle = Nothing,
useWorkingDir = Nothing
}
reportingLevel = fromFlag (installBuildReports installFlags)
useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath)
useLogFile logsDir = fmap substLogFileName logFileTemplate
where
logFileTemplate :: Maybe PathTemplate
logFileTemplate --TODO: separate policy from mechanism
| reportingLevel == DetailedReports
= Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"
| otherwise
= flagToMaybe (installLogFile installFlags)
substLogFileName template pkg = fromPathTemplate
. substPathTemplate env
$ template
where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)
dryRun = fromFlag (installDryRun installFlags)
miscOptions = InstallMisc {
rootCmd = if fromFlag (configUserInstall configFlags)
then Nothing -- ignore --root-cmd if --user.
else flagToMaybe (installRootCmd installFlags),
libVersion = flagToMaybe (configCabalVersion configExFlags)
}
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
installed <- getInstalledPackages verbosity comp packageDBs conf
case installed of
Nothing -> return () -- warning ?
Just index -> Haddock.regenerateHaddockIndex verbosity index 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)
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
-> ConfigFlags -> ConfigExFlags -> Planner
planLocalPackage verbosity comp configFlags configExFlags installed
(AvailablePackageDb available availablePrefs) = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
let -- The trick is, we add the local package to the available index and
-- remove it from the installed index. Then we ask to resolve a
-- dependency on exactly that package. So the resolver ends up having
-- to pick the local package.
available' = PackageIndex.insert localPkg available
installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed
localPkg = AvailablePackage {
packageInfoId = packageId pkg,
Available.packageDescription = pkg,
packageSource = LocalUnpackedPackage
}
targets = [packageName pkg]
constraints = [PackageVersionConstraint (packageName pkg)
(thisVersion (packageVersion pkg))
,PackageFlagsConstraint (packageName pkg)
(configConfigurationsFlags configFlags)]
++ [ PackageVersionConstraint name ver
| Dependency name ver <- configConstraints configFlags ]
preferences = mergePackagePrefs PreferLatestForSelected
availablePrefs configExFlags
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available' preferences constraints targets
-- | Make an 'InstallPlan' for the given dependencies.
--
planRepoPackages :: PackagesPreferenceDefault -> Compiler
-> ConfigFlags -> ConfigExFlags -> InstallFlags
-> [UnresolvedDependency] -> Planner
planRepoPackages defaultPref comp configFlags configExFlags installFlags
deps installed (AvailablePackageDb available availablePrefs) = do
deps' <- IndexUtils.disambiguateDependencies available deps
let installed'
| fromFlag (installReinstall installFlags)
= fmap (hideGivenDeps deps') installed
| otherwise = installed
targets = dependencyTargets deps'
constraints = dependencyConstraints deps'
++ [ PackageVersionConstraint name ver
| Dependency name ver <- configConstraints configFlags ]
preferences = mergePackagePrefs defaultPref availablePrefs configExFlags
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available preferences constraints targets
where
hideGivenDeps pkgs index =
foldr PackageIndex.deletePackageName index
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner
planUpgradePackages _comp _configFlags _configExFlags (Just installed)
(AvailablePackageDb available _availablePrefs) = die $
"the 'upgrade' command (when used without any package arguments) has "
++ "been disabled in this release. It has been disabled because it has "
++ "frequently led people to accidentally break their set of installed "
++ "packages. It will be re-enabled when it is safer to use.\n"
++ "Below is the list of packages that it would have tried to upgrade. You "
++ "can use the 'install' command to install the ones you want. Note that "
++ "it is generally not recommended to upgrade core packages.\n"
++ unlines [ display pkgid | Dependency pkgid _ <- deps ]
--TODO: improve upgrade so we can re-enable it
-- return $
-- resolveDependenciesWithProgress buildPlatform (compilerId comp)
-- (Just installed) available preferences constraints targets
where
deps = upgradableDependencies installed available
-- preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags
-- constraints = [ PackageVersionConstraint name ver
-- | Dependency name ver <- deps ]
-- ++ [ PackageVersionConstraint name ver
-- | Dependency name ver <- configConstraints configFlags ]
-- targets = [ name | Dependency name _ <- deps ]
planUpgradePackages comp _ _ _ _ =
die $ display (compilerId comp)
++ " does not track installed packages so cabal cannot figure out what"
++ " packages need to be upgraded."
mergePackagePrefs :: PackagesPreferenceDefault
-> Map.Map PackageName VersionRange
-> ConfigExFlags
-> PackagesPreference
mergePackagePrefs defaultPref availablePrefs configExFlags =
PackagesPreference defaultPref $
-- The preferences that come from the hackage index
[ PackageVersionPreference name ver
| (name, ver) <- Map.toList availablePrefs ]
-- additional preferences from the config file or command line
++ [ PackageVersionPreference name ver
| Dependency name ver <- configPreferences configExFlags ]
printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage)
-> InstallPlan -> IO ()
printDryRun verbosity minstalled plan = case unfoldr next plan of
[] -> return ()
pkgs
| verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
"In order, the following would be installed:"
: map showPkgAndReason pkgs
| otherwise -> notice verbosity $ unlines $
"In order, the following would be installed (use -v for more details):"
: map (display . packageId) pkgs
where
next plan' = case InstallPlan.ready plan' of
[] -> Nothing
(pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')
where pkgid = packageId pkg
result = BuildOk DocsNotTried TestsNotTried
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
showPkgAndReason pkg' = display (packageId pkg') ++ " " ++
case minstalled of
Nothing -> ""
Just installed ->
case PackageIndex.lookupPackageName installed (packageName pkg') of
[] -> "(new package)"
ps -> case find ((==packageId pkg') . packageId) ps of
Nothing -> "(new version)"
Just pkg -> "(reinstall)" ++ case changes pkg pkg' of
[] -> ""
diff -> " changes: " ++ intercalate ", " diff
changes pkg pkg' = map change . filter changed
$ mergeBy (comparing packageName)
(nub . sort . depends $ pkg)
(nub . sort . depends $ pkg')
change (OnlyInLeft pkgid) = display pkgid ++ " removed"
change (InBoth pkgid pkgid') = display pkgid ++ " -> "
++ display (packageVersion pkgid')
change (OnlyInRight pkgid') = display pkgid' ++ " added"
changed (InBoth pkgid pkgid') = pkgid /= pkgid'
changed _ = True
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
InstallFailed e -> " failed during the final install step."
++ " The exception was:\n " ++ show e
executeInstallPlan :: Monad m
=> InstallPlan
-> (ConfiguredPackage -> m BuildResult)
-> m InstallPlan
executeInstallPlan plan installPkg = case InstallPlan.ready plan of
[] -> return plan
(pkg: _) -> do buildResult <- installPkg pkg
let plan' = updatePlan (packageId pkg) buildResult plan
executeInstallPlan plan' installPkg
where
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.
-- | Call an installer for an 'AvailablePackage' 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 -> AvailablePackageSource
-> PackageDescription -> a)
-> a
installConfiguredPackage platform comp configFlags
(ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)
installPkg = installPkg configFlags {
configConfigurationsFlags = flags,
configConstraints = map thisPackageVersion deps
} source pkg
where
pkg = case finalizePackageDescription flags
(const True)
platform comp [] gpkg of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Right (desc, _) -> desc
installAvailablePackage
:: Verbosity -> PackageIdentifier -> AvailablePackageSource
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
installAvailablePackage _ _ LocalUnpackedPackage installPkg =
installPkg Nothing
installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =
onFailure DownloadFailed $ do
pkgPath <- fetchPackage verbosity repo pkgid
onFailure UnpackFailed $ do
tmp <- getTemporaryDirectory
withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do
info verbosity $ "Extracting " ++ pkgPath
++ " to " ++ tmpDirPath ++ "..."
let relUnpackedPath = display pkgid
absUnpackedPath = tmpDirPath </> relUnpackedPath
descFilePath = absUnpackedPath
</> display (packageName pkgid) <.> "cabal"
extractTarGzFile tmpDirPath relUnpackedPath pkgPath
exists <- doesFileExist descFilePath
when (not exists) $
die $ "Package .cabal file not found: " ++ show descFilePath
installPkg (Just absUnpackedPath)
installUnpackedPackage :: Verbosity
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
-> InstallFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity scriptOptions miscOptions
configFlags installConfigFlags
compid pkg workingDir useLogFile =
-- Configure phase
onFailure ConfigureFailed $ do
setup configureCommand configureFlags
-- Build phase
onFailure BuildFailed $ do
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
testsResult <- return TestsNotTried --TODO: add optional tests
-- Install phase
onFailure InstallFailed $
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
configureFlags = filterConfigureFlags configFlags {
configVerbosity = toFlag verbosity'
}
buildCommand' = buildCommand defaultProgramConfiguration
buildFlags _ = emptyBuildFlags {
buildDistPref = configDistPref configFlags,
buildVerbosity = toFlag verbosity'
}
shouldHaddock = fromFlag (installDocumentation installConfigFlags)
haddockFlags _ = emptyHaddockFlags {
haddockDistPref = configDistPref configFlags,
haddockVerbosity = toFlag verbosity'
}
installFlags _ = Cabal.emptyInstallFlags {
Cabal.installDistPref = configDistPref configFlags,
Cabal.installVerbosity = toFlag verbosity'
}
verbosity' | isJust useLogFile = max Verbosity.verbose verbosity
| otherwise = verbosity
setup cmd flags = do
logFileHandle <- 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)
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
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