From 03b02fb6ef23988543bda937bda029262ebbaf17 Mon Sep 17 00:00:00 2001 From: Johan Tibell Date: Mon, 1 Jun 2015 01:33:34 +0200 Subject: [PATCH] Allow using cabal program itself as the external setup method This fixes issues when the version of Cabal that cabal-install was built against differs from the one registered in the local package DB. Normally we compile an external setup against the local Cabal library, which could lead to failures or inconsistent results compared to using the internal method. This fixes #2438 and fixes #1938. --- cabal-install/Distribution/Client/Setup.hs | 44 ++++++++++++++++- .../Distribution/Client/SetupWrapper.hs | 49 +++++++++++++++++-- cabal-install/Main.hs | 23 ++++++++- 3 files changed, 108 insertions(+), 8 deletions(-) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 3db3c79c13d..fef2ca5dda9 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -35,6 +35,7 @@ module Distribution.Client.Setup , initCommand, IT.InitFlags(..) , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) + , actAsSetupCommand, ActAsSetupFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) , execCommand, ExecFlags(..) , userConfigCommand, UserConfigFlags(..) @@ -79,7 +80,7 @@ import Distribution.Version import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.PackageDescription - ( RepoKind(..) ) + ( BuildType(..), RepoKind(..) ) import Distribution.Text ( Text(..), display ) import Distribution.ReadE @@ -1813,6 +1814,47 @@ instance Monoid Win32SelfUpgradeFlags where } where combine field = field a `mappend` field b +-- ------------------------------------------------------------ +-- * ActAsSetup flags +-- ------------------------------------------------------------ + +data ActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType :: Flag BuildType +} + +defaultActAsSetupFlags :: ActAsSetupFlags +defaultActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType = toFlag Simple +} + +actAsSetupCommand :: CommandUI ActAsSetupFlags +actAsSetupCommand = CommandUI { + commandName = "act-as-setup", + commandSynopsis = "Run as-if this was a Setup.hs", + commandDescription = Nothing, + commandNotes = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " act-as-setup\n", + commandDefaultFlags = defaultActAsSetupFlags, + commandOptions = \_ -> + [option "" ["build-type"] + "Use the given build type." + actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) + (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++) + (fmap toFlag parse)) + (map display . flagToList)) + ] +} + +instance Monoid ActAsSetupFlags where + mempty = ActAsSetupFlags { + actAsSetupBuildType = mempty + } + mappend a b = ActAsSetupFlags { + actAsSetupBuildType = combine actAsSetupBuildType + } + where combine field = field a `mappend` field b + -- ------------------------------------------------------------ -- * Sandbox-related flags -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index d92dcb61544..90ca68c92c6 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -105,6 +105,7 @@ import Control.Monad ( when, unless ) import Data.List ( foldl1' ) import Data.Maybe ( fromMaybe, isJust ) import Data.Char ( isSpace ) +import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) #ifdef mingw32_HOST_OS import Distribution.Simple.Utils @@ -222,12 +223,22 @@ setupWrapper verbosity options mpkg cmd flags extraArgs = do -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType' - | forceExternalSetupMethod options = externalSetupMethod + -- This order is picked so that it's stable. The build type and + -- required cabal version are external info, coming from .cabal + -- files and the command line. Those do switch between the + -- external and self & internal methods, but that info itself can + -- be considered stable. The logging and force-external conditions + -- are internally generated choices but now these only switch + -- between the self and internal setup methods, which are + -- consistent with each other. + | buildType' == Custom = externalSetupMethod + | not (cabalVersion `withinRange` + useCabalVersion options) = externalSetupMethod | isJust (useLoggingHandle options) - || buildType' == Custom = externalSetupMethod - | cabalVersion `withinRange` - useCabalVersion options = internalSetupMethod - | otherwise = externalSetupMethod + -- Forcing is done to use an external process e.g. due to parallel + -- build concerns. + || forceExternalSetupMethod options = selfExecSetupMethod + | otherwise = internalSetupMethod type SetupMethod = Verbosity -> SetupScriptOptions @@ -255,6 +266,34 @@ buildTypeAction Make = Make.defaultMainArgs buildTypeAction Custom = error "buildTypeAction Custom" buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" +-- ------------------------------------------------------------ +-- * Self-Exec SetupMethod +-- ------------------------------------------------------------ + +selfExecSetupMethod :: SetupMethod +selfExecSetupMethod verbosity options _pkg bt mkargs = do + let args = ["act-as-setup", + "--build-type=" ++ display bt, + "--"] ++ mkargs cabalVersion + debug verbosity $ "Using self-exec internal setup method with build-type " + ++ show bt ++ " and args:\n " ++ show args + path <- getExecutablePath + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + searchpath <- programSearchPathAsPATHVar + (getProgramSearchPath (useProgramConfig options)) + env <- getEffectiveEnvironment [("PATH", Just searchpath)] + + process <- runProcess path args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + -- ------------------------------------------------------------ -- * External SetupMethod -- ------------------------------------------------------------ diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 5289e82820f..5beb93f330e 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -37,6 +37,7 @@ import Distribution.Client.Setup , InitFlags(initVerbosity), initCommand , SDistFlags(..), SDistExFlags(..), sdistCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , ActAsSetupFlags(..), actAsSetupCommand , SandboxFlags(..), sandboxCommand , ExecFlags(..), execCommand , UserConfigFlags(..), userConfigCommand @@ -112,12 +113,14 @@ import Distribution.Client.Utils (determineNumJobs ,existsAndIsMoreRecentThan) import Distribution.PackageDescription - ( Executable(..), benchmarkName, benchmarkBuildInfo, testName - , testBuildInfo, buildable ) + ( BuildType(..), Executable(..), benchmarkName, benchmarkBuildInfo + , testName, testBuildInfo, buildable ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) +import qualified Distribution.Simple as Simple +import qualified Distribution.Make as Make import Distribution.Simple.Build ( startInterpreter ) import Distribution.Simple.Command @@ -262,6 +265,8 @@ mainWorker args = topHandler $ upgradeCommand `commandAddAction` upgradeAction ,hiddenCommand $ win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction + ,hiddenCommand $ + actAsSetupCommand`commandAddAction` actAsSetupAction ] wrapperAction :: Monoid flags @@ -1155,3 +1160,17 @@ win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path win32SelfUpgradeAction _ _ _ = return () + +-- | Used as an entry point when cabal-install needs to invoke itself +-- as a setup script. This can happen e.g. when doing parallel builds. +-- +actAsSetupAction :: ActAsSetupFlags -> [String] -> GlobalFlags -> IO () +actAsSetupAction actAsSetupFlags args _globalFlags = + let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" + (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"