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.

Author: tibbe

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
 -- ------------------------------------------------------------

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
 -- ------------------------------------------------------------

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"