Commit 729658bc authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Use globalInstallDirs as the sandbox location.

Reverts 7b2e3630. Instead of temporarily setting
'configUserInstall' to 'False' in various places, we now just check that we're
not in a sandbox when deciding whether we should use 'rootCmd'.
parent b4635587
......@@ -56,7 +56,6 @@ 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
......@@ -67,6 +66,7 @@ import Distribution.Client.Setup
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
( defaultCabalDir )
import Distribution.Client.Sandbox.Types ( isUseSandbox )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
......@@ -905,7 +905,9 @@ performInstallations verbosity
miscOptions = InstallMisc {
rootCmd = if fromFlag (configUserInstall configFlags)
then Nothing -- ignore --root-cmd if --user.
|| isUseSandbox (installUseSandbox installFlags)
then Nothing -- ignore --root-cmd if --user
-- or working inside a sandbox.
else flagToMaybe (installRootCmd installFlags),
libVersion = flagToMaybe (configCabalVersion configExFlags)
}
......
......@@ -18,8 +18,6 @@ module Distribution.Client.Sandbox (
dumpPackageEnvironment,
withSandboxBinDirOnSearchPath,
UseSandbox(..), isUseSandbox, whenUsingSandbox,
ForceGlobalInstall(UseDefaultPackageDBStack), maybeForceGlobalInstall,
loadConfigOrSandboxConfig,
initPackageDBIfNeeded,
maybeWithSandboxDirOnSearchPath,
......@@ -59,6 +57,7 @@ import Distribution.Client.Sandbox.PackageEnvironment
, commentPackageEnvironment, showPackageEnvironmentWithComments
, sandboxPackageEnvironmentFile, updatePackageEnvironment
, userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types ( UseSandbox(..) )
import Distribution.Client.Targets ( UserTarget(..)
, readUserTargets
, resolveUserTargets )
......@@ -407,30 +406,11 @@ sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
(_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity
(globalConfigFile globalFlags)
let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
dbStack = configPackageDB' configFlags ForceGlobalInstall
dbStack = configPackageDB' configFlags
(comp, _platform, conf) <- configCompilerAux' configFlags
Register.invokeHcPkg verbosity comp conf dbStack extraArgs
--
-- * Helpers for writing code that works both inside and outside a sandbox.
--
-- | Are we using a sandbox?
data UseSandbox = UseSandbox FilePath | NoSandbox
-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with
-- @when@.
isUseSandbox :: UseSandbox -> Bool
isUseSandbox (UseSandbox _) = True
isUseSandbox NoSandbox = False
-- | Execute an action only if we're in a sandbox, feeding to it the path to the
-- sandbox directory.
whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()
whenUsingSandbox NoSandbox _ = return ()
whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir
-- | Check which type of package environment we're in and return a
-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
-- whether we're working in a sandbox.
......@@ -498,7 +478,7 @@ reinstallAddSourceDeps verbosity config configFlags' configExFlags
targets <- readUserTargets verbosity targetNames
let args :: InstallArgs
args = ((configPackageDB' configFlags ForceGlobalInstall)
args = ((configPackageDB' configFlags)
,(globalRepos globalFlags)
,comp, platform, conf
,globalFlags, configFlags, configExFlags, installFlags
......@@ -576,8 +556,9 @@ maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do
installFlags' = defaultInstallFlags
`mappend` savedInstallFlags config
installFlags = installFlags' {
installNumJobs = installNumJobs installFlags'
`mappend` numJobsFlag
installNumJobs = installNumJobs installFlags'
`mappend` numJobsFlag,
installUseSandbox = useSandbox
}
globalFlags = savedGlobalFlags config
-- This makes it possible to override things like
......@@ -644,35 +625,11 @@ updateSandboxConfig verbosity newConfigFlags = do
-- module
--
-- | Force the usage of the global package DB even though @configUserInstall@
-- may be @True@.
--
-- We use @userInstallDirs@ in sandbox mode to prevent @cabal-install@ from
-- doing unnecessary things like invoking itself via @sudo@ (see commit
-- 7b2e3630f2ada8a56bf9100144e1bb9acbe6dc6a and 'rootCmd' in
-- "Distribution.Client.Install"), but in this particular case we want
-- @configUserInstall@ to be @False@ to prevent @UserPackageDB@ from being added
-- to the package DB stack (see #1183 and @interpretPackageDbFlags@ in
-- "Distribution.Simple.Configure").
--
-- In the future we may want to distinguish between global, user and sandbox
-- install types.
data ForceGlobalInstall = ForceGlobalInstall
| UseDefaultPackageDBStack
-- | If we're in a sandbox, add only the global package db to the package db
-- stack, otherwise use the default behaviour.
maybeForceGlobalInstall :: UseSandbox -> ForceGlobalInstall
maybeForceGlobalInstall NoSandbox = UseDefaultPackageDBStack
maybeForceGlobalInstall (UseSandbox _) = ForceGlobalInstall
configPackageDB' :: ConfigFlags -> ForceGlobalInstall -> PackageDBStack
configPackageDB' cfg force =
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
interpretPackageDbFlags userInstall (configPackageDBs cfg)
where
userInstall = case force of
ForceGlobalInstall -> False
UseDefaultPackageDBStack -> fromFlagOrDefault True (configUserInstall cfg)
userInstall = fromFlagOrDefault True (configUserInstall cfg)
configCompilerAux' :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
......
......@@ -127,7 +127,10 @@ commonPackageEnvironmentConfig :: FilePath -> SavedConfig
commonPackageEnvironmentConfig sandboxDir =
mempty {
savedConfigureFlags = mempty {
configUserInstall = toFlag True,
-- TODOи: Currently, we follow cabal-dev and set 'user-install: False' in
-- the config file. In the future we may want to distinguish between
-- global, sandbox and user install types.
configUserInstall = toFlag False,
configInstallDirs = installDirs
},
savedUserInstallDirs = installDirs,
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Sandbox.Types
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Helpers for writing code that works both inside and outside a sandbox.
-----------------------------------------------------------------------------
module Distribution.Client.Sandbox.Types (
UseSandbox(..), isUseSandbox, whenUsingSandbox
) where
import Data.Monoid
-- | Are we using a sandbox?
data UseSandbox = UseSandbox FilePath | NoSandbox
instance Monoid UseSandbox where
mempty = NoSandbox
NoSandbox `mappend` s = s
u0@(UseSandbox _) `mappend` NoSandbox = u0
(UseSandbox _) `mappend` u1@(UseSandbox _) = u1
-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with
-- @when@.
isUseSandbox :: UseSandbox -> Bool
isUseSandbox (UseSandbox _) = True
isUseSandbox NoSandbox = False
-- | Execute an action only if we're in a sandbox, feeding to it the path to the
-- sandbox directory.
whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()
whenUsingSandbox NoSandbox _ = return ()
whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir
......@@ -44,6 +44,8 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..) )
import Distribution.Client.Sandbox.Types
( UseSandbox(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
......@@ -682,7 +684,8 @@ data InstallFlags = InstallFlags {
installBuildReports :: Flag ReportLevel,
installSymlinkBinDir :: Flag FilePath,
installOneShot :: Flag Bool,
installNumJobs :: Flag (Maybe Int)
installNumJobs :: Flag (Maybe Int),
installUseSandbox :: UseSandbox
}
defaultInstallFlags :: InstallFlags
......@@ -706,7 +709,8 @@ defaultInstallFlags = InstallFlags {
installBuildReports = Flag NoReports,
installSymlinkBinDir = mempty,
installOneShot = Flag False,
installNumJobs = mempty
installNumJobs = mempty,
installUseSandbox = mempty
}
where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
......@@ -898,7 +902,8 @@ instance Monoid InstallFlags where
installBuildReports = mempty,
installSymlinkBinDir = mempty,
installOneShot = mempty,
installNumJobs = mempty
installNumJobs = mempty,
installUseSandbox = mempty
}
mappend a b = InstallFlags {
installDocumentation = combine installDocumentation,
......@@ -920,7 +925,8 @@ instance Monoid InstallFlags where
installBuildReports = combine installBuildReports,
installSymlinkBinDir = combine installSymlinkBinDir,
installOneShot = combine installOneShot,
installNumJobs = combine installNumJobs
installNumJobs = combine installNumJobs,
installUseSandbox = combine installUseSandbox
}
where combine field = field a `mappend` field b
......
......@@ -74,10 +74,6 @@ import Distribution.Client.Sandbox (sandboxInit
,sandboxHcPkg
,dumpPackageEnvironment
,UseSandbox(..)
,whenUsingSandbox
,ForceGlobalInstall(..)
,maybeForceGlobalInstall
,loadConfigOrSandboxConfig
,initPackageDBIfNeeded
,maybeWithSandboxDirOnSearchPath
......@@ -93,6 +89,7 @@ import Distribution.Client.Sandbox (sandboxInit
import Distribution.Client.Sandbox.PackageEnvironment
(setPackageDB)
import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord)
import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
......@@ -226,12 +223,6 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
(globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
-- See the comment in D.C.Sandbox. Otherwise configure
-- adds the user package DB to the package DB stack.
-- FIXME: Maybe we should set configUserInstall = False
-- and fix the sudo issue in some other way?
{ configUserInstall = Flag False}
configExFlags' = savedConfigureExFlags config `mappend` configExFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux configFlags'
......@@ -255,8 +246,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
maybeWithSandboxDirOnSearchPath useSandbox $
configure verbosity
(configPackageDB' configFlags''
(maybeForceGlobalInstall useSandbox))
(configPackageDB' configFlags'')
(globalRepos globalFlags')
comp platform conf configFlags'' configExFlags' extraArgs
......@@ -470,6 +460,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
{ installUseSandbox = useSandbox }
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags'
......@@ -504,7 +495,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
maybeWithSandboxDirOnSearchPath useSandbox $
install verbosity
(configPackageDB' configFlags'' (maybeForceGlobalInstall useSandbox))
(configPackageDB' configFlags'')
(globalRepos globalFlags')
comp platform conf globalFlags' configFlags'' configExFlags'
installFlags' haddockFlags
......@@ -566,7 +557,7 @@ listAction listFlags extraArgs globalFlags = do
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, conf) <- configCompilerAux' configFlags
List.list verbosity
(configPackageDB' configFlags UseDefaultPackageDBStack)
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp
conf
......@@ -583,7 +574,7 @@ infoAction infoFlags extraArgs globalFlags = do
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, conf) <- configCompilerAux configFlags
List.info verbosity
(configPackageDB' configFlags UseDefaultPackageDBStack)
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp
conf
......@@ -624,7 +615,7 @@ fetchAction fetchFlags extraArgs globalFlags = do
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags
fetch verbosity
(configPackageDB' configFlags UseDefaultPackageDBStack)
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp platform conf globalFlags' fetchFlags
targets
......@@ -733,7 +724,7 @@ initAction initFlags _extraArgs globalFlags = do
let configFlags = savedConfigureFlags config
(comp, _, conf) <- configCompilerAux' configFlags
initCabal verbosity
(configPackageDB' configFlags UseDefaultPackageDBStack)
(configPackageDB' configFlags)
comp
conf
initFlags
......
......@@ -93,6 +93,7 @@ executable cabal
Distribution.Client.Sandbox.Index
Distribution.Client.Sandbox.PackageEnvironment
Distribution.Client.Sandbox.Timestamp
Distribution.Client.Sandbox.Types
Distribution.Client.Setup
Distribution.Client.SetupWrapper
Distribution.Client.SrcDist
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment