Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Implement the 'require-sandbox' option. #1625

Merged
merged 1 commit into from

2 participants

Mikhail Glushenkov Johan Tibell
Mikhail Glushenkov
Collaborator

Fixes #1596.

Johan Tibell
Owner

LGTM

Mikhail Glushenkov 23Skidoo merged commit 3c156e3 into from
Mikhail Glushenkov 23Skidoo deleted the 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. Mikhail Glushenkov
This page is out of date. Refresh to see the latest.
4 cabal-install/Distribution/Client/Config.hs
View
@@ -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) {
16 cabal-install/Distribution/Client/Sandbox.hs
View
@@ -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
32 cabal-install/Distribution/Client/Setup.hs
View
@@ -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)
10 cabal-install/Main.hs
View
@@ -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.