Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Implement the 'require-sandbox' option. #1625

Merged
merged 1 commit into from

2 participants

@23Skidoo
Collaborator

Fixes #1596.

@tibbe
Owner

LGTM

@23Skidoo 23Skidoo merged commit 3c156e3 into haskell:master
@23Skidoo 23Skidoo deleted the 23Skidoo:require-sandbox branch
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Dec 19, 2013
  1. @23Skidoo
This page is out of date. Refresh to see the latest.
View
4 cabal-install/Distribution/Client/Config.hs
@@ -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) {
View
16 cabal-install/Distribution/Client/Sandbox.hs
@@ -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
View
32 cabal-install/Distribution/Client/Setup.hs
@@ -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)
View
10 cabal-install/Main.hs
@@ -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'
Something went wrong with that request. Please try again.