Commit 39381c95 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Implement the 'require-sandbox' option.

Fixes #1596.
parent 6a9ef738
......@@ -39,7 +39,7 @@ import Distribution.Client.Types
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand
( GlobalFlags(..), globalCommand, defaultGlobalFlags
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
......@@ -348,7 +348,7 @@ commentSavedConfig = do
userInstallDirs <- defaultInstallDirs defaultCompiler True True
globalInstallDirs <- defaultInstallDirs defaultCompiler False True
return SavedConfig {
savedGlobalFlags = commandDefaultFlags globalCommand,
savedGlobalFlags = defaultGlobalFlags,
savedInstallFlags = defaultInstallFlags,
savedConfigureExFlags = defaultConfigExFlags,
savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) {
......
......@@ -496,13 +496,27 @@ loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do
UserPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag userInstallFlag
userConfig <- loadUserConfig verbosity pkgEnvDir
return (NoSandbox, config `mappend` userConfig)
let config' = config `mappend` userConfig
dieIfSandboxRequired config'
return (NoSandbox, config')
-- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
AmbientPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag userInstallFlag
dieIfSandboxRequired config
return (NoSandbox, config)
where
dieIfSandboxRequired :: SavedConfig -> IO ()
dieIfSandboxRequired config = checkFlag flag
where
flag = (globalRequireSandbox . savedGlobalFlags $ config)
`mappend` (globalRequireSandbox globalFlags)
checkFlag (Flag True) =
die $ "'require-sandbox' is set to True, but no sandbox is present."
checkFlag (Flag False) = return ()
checkFlag (NoFlag) = return ()
-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
-- nothing.
maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
......
......@@ -11,7 +11,7 @@
--
-----------------------------------------------------------------------------
module Distribution.Client.Setup
( globalCommand, GlobalFlags(..), globalRepos
( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos
, configureCommand, ConfigFlags(..), filterConfigureFlags
, configureExCommand, ConfigExFlags(..), defaultConfigExFlags
, configureExOptions
......@@ -54,14 +54,15 @@ import Distribution.Client.Targets
import Distribution.Simple.Compiler (PackageDB)
import Distribution.Simple.Program
( defaultProgramConfiguration )
import Distribution.Simple.Command hiding (boolOpt)
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)
, SDistFlags(..), HaddockFlags(..)
, readPackageDbList, showPackageDbList
, Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
, optionVerbosity, boolOpt, trueArg, falseArg, optionNumJobs )
, optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )
import Distribution.Simple.InstallDirs
( PathTemplate, InstallDirs(sysconfdir)
, toPathTemplate, fromPathTemplate )
......@@ -111,7 +112,8 @@ data GlobalFlags = GlobalFlags {
globalCacheDir :: Flag FilePath,
globalLocalRepos :: [FilePath],
globalLogsDir :: Flag FilePath,
globalWorldFile :: Flag FilePath
globalWorldFile :: Flag FilePath,
globalRequireSandbox :: Flag Bool
}
defaultGlobalFlags :: GlobalFlags
......@@ -120,11 +122,12 @@ defaultGlobalFlags = GlobalFlags {
globalNumericVersion = Flag False,
globalConfigFile = mempty,
globalSandboxConfigFile = mempty,
globalRemoteRepos = [],
globalRemoteRepos = mempty,
globalCacheDir = mempty,
globalLocalRepos = mempty,
globalLogsDir = mempty,
globalWorldFile = mempty
globalWorldFile = mempty,
globalRequireSandbox = Flag False
}
globalCommand :: CommandUI GlobalFlags
......@@ -142,9 +145,9 @@ globalCommand = CommandUI {
++ " " ++ pname ++ " install foo [--dry-run]\n\n"
++ "Occasionally you need to update the list of available packages:\n"
++ " " ++ pname ++ " update\n",
commandDefaultFlags = defaultGlobalFlags,
commandDefaultFlags = mempty,
commandOptions = \showOrParseArgs ->
(case showOrParseArgs of ShowArgs -> take 4; ParseArgs -> id)
(case showOrParseArgs of ShowArgs -> take 5; ParseArgs -> id)
[option ['V'] ["version"]
"Print version information"
globalVersion (\v flags -> flags { globalVersion = v })
......@@ -166,6 +169,11 @@ globalCommand = CommandUI {
globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })
(reqArgFlag "FILE")
,option [] ["require-sandbox"]
"Require the presence of a sandbox for sandbox-aware commands"
globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })
(boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))
,option [] ["remote-repo"]
"The name and url for a remote repository"
globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
......@@ -203,7 +211,8 @@ instance Monoid GlobalFlags where
globalCacheDir = mempty,
globalLocalRepos = mempty,
globalLogsDir = mempty,
globalWorldFile = mempty
globalWorldFile = mempty,
globalRequireSandbox = mempty
}
mappend a b = GlobalFlags {
globalVersion = combine globalVersion,
......@@ -214,7 +223,8 @@ instance Monoid GlobalFlags where
globalCacheDir = combine globalCacheDir,
globalLocalRepos = combine globalLocalRepos,
globalLogsDir = combine globalLogsDir,
globalWorldFile = combine globalWorldFile
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox
}
where combine field = field a `mappend` field b
......@@ -1568,7 +1578,7 @@ liftOptions get set = map (liftOption get set)
yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt ShowArgs sf lf = trueArg sf lf
yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
optionSolver :: (flags -> Flag PreSolver)
-> (Flag PreSolver -> flags -> flags)
......
......@@ -150,8 +150,10 @@ mainWorker args = topHandler $
CommandErrors errs -> printErrors errs
CommandReadyToGo (globalflags, commandParse) ->
case commandParse of
_ | fromFlag (globalVersion globalflags) -> printVersion
| fromFlag (globalNumericVersion globalflags) -> printNumericVersion
_ | fromFlagOrDefault False (globalVersion globalflags)
-> printVersion
| fromFlagOrDefault False (globalNumericVersion globalflags)
-> printNumericVersion
CommandHelp help -> printCommandHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
......@@ -700,7 +702,7 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
(_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let configFlags' = savedConfigureFlags config
configFlags = configFlags' {
configPackageDBs = configPackageDBs configFlags'
......@@ -720,7 +722,7 @@ infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()
infoAction infoFlags extraArgs globalFlags = do
let verbosity = fromFlag (infoVerbosity infoFlags)
targets <- readUserTargets verbosity extraArgs
(_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let configFlags' = savedConfigureFlags config
configFlags = configFlags' {
configPackageDBs = configPackageDBs configFlags'
......
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