From 4cf508fc513d42ebe6c9549e0804ba5b9e5832b0 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 15 Dec 2023 17:11:08 +0100 Subject: [PATCH] Fix extra-prog-path propagation in the codebase. Extra prog paths were being handled in many different ways all thorugh the codebase. This PR introduces a unified way to look at them. Aiming for traceability, the addition of extra paths is now traced via `logExtraProgramSearchPath`. All appearances of `modifyProgramSearchPath` are replaced with `appendProgramSearchPath` which traces the added paths. `progInvokePathEnv` was only being set by GHC for some paths to executables in components and only under certain circumstances. Now every `ghcInvocation` sets the extra paths directly into `pkgInvokeEnv`. In particular this fixes PATH issues when running MinGW cabal in PowerShell, as usually for other OSes the system path contains most of the expected directories. --- Cabal/src/Distribution/Simple/Configure.hs | 33 +++++++------- .../Distribution/Simple/ConfigureScript.hs | 5 +-- Cabal/src/Distribution/Simple/GHC.hs | 4 +- Cabal/src/Distribution/Simple/GHCJS.hs | 2 +- Cabal/src/Distribution/Simple/Program/Db.hs | 13 ++++++ Cabal/src/Distribution/Simple/Program/Find.hs | 30 +++++++++++++ Cabal/src/Distribution/Simple/Program/GHC.hs | 23 ++++++---- Cabal/src/Distribution/Simple/Program/Run.hs | 29 ++---------- .../src/Distribution/Simple/Program/Types.hs | 7 +++ .../src/Distribution/Client/CmdExec.hs | 45 +++++++++++-------- .../src/Distribution/Client/CmdInstall.hs | 18 +++----- .../src/Distribution/Client/CmdRun.hs | 31 +++++++++++-- .../src/Distribution/Client/Config.hs | 8 ++++ cabal-install/src/Distribution/Client/Get.hs | 12 +++-- .../src/Distribution/Client/HttpUtils.hs | 7 ++- .../src/Distribution/Client/ProjectConfig.hs | 5 +-- .../Client/ProjectOrchestration.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 17 +++---- .../src/Distribution/Client/SetupWrapper.hs | 14 +++--- cabal-install/src/Distribution/Client/VCS.hs | 14 ++++-- .../UnitTests/Distribution/Client/Get.hs | 21 +++++---- .../UnitTests/Distribution/Client/VCS.hs | 4 +- changelog.d/propagate-extra-prog-path | 13 ++++++ 23 files changed, 222 insertions(+), 135 deletions(-) create mode 100644 changelog.d/propagate-extra-prog-path diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 1cd864a290b..dfc295851d9 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -86,7 +86,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PreProcess import Distribution.Simple.Program -import Distribution.Simple.Program.Db (lookupProgramByName) +import Distribution.Simple.Program.Db (appendProgramSearchPath, lookupProgramByName) import Distribution.Simple.Setup.Common as Setup import Distribution.Simple.Setup.Config as Setup import Distribution.Simple.Utils @@ -462,6 +462,7 @@ configure (pkg_descr0, pbi) cfg = do (fromFlag (configUserInstall cfg)) (configPackageDBs cfg) + programDbPre <- mkProgramDb cfg (configPrograms cfg) -- comp: the compiler we're building with -- compPlatform: the platform we're building for -- programDb: location and args of all programs we're @@ -474,7 +475,7 @@ configure (pkg_descr0, pbi) cfg = do (flagToMaybe (configHcFlavor cfg)) (flagToMaybe (configHcPath cfg)) (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) + programDbPre (lessVerbose verbosity) -- The InstalledPackageIndex of all installed packages @@ -1008,19 +1009,18 @@ configure (pkg_descr0, pbi) cfg = do mkPromisedDepsSet :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId mkPromisedDepsSet comps = Map.fromList [((pn, CLibName ln), cid) | GivenComponent pn ln cid <- comps] -mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb -mkProgramDb cfg initialProgramDb = programDb +-- | Adds the extra program paths from the flags provided to @configure@ as +-- well as specified locations for certain known programs and their default +-- arguments. +mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb cfg initialProgramDb = do + programDb <- appendProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath initialProgramDb + pure + . userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ programDb where - programDb = - userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramDb - searchpath = - getProgramSearchPath initialProgramDb - ++ map - ProgramSearchPathDir - (fromNubList $ configProgramPathExtra cfg) + searchpath = fromNubList $ configProgramPathExtra cfg -- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path -- so that we can override the system path. However, in a v2-build, at this point, the "system" path @@ -2083,15 +2083,14 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static = configCompilerAuxEx :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = +configCompilerAuxEx cfg = do + programDb <- mkProgramDb cfg defaultProgramDb configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) programDb (fromFlag (configVerbosity cfg)) - where - programDb = mkProgramDb cfg defaultProgramDb configCompilerEx :: Maybe CompilerFlavor diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index c4ec2fc0f95..2572f4949c1 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -169,10 +169,7 @@ runConfigureScript verbosity flags lbi = do maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag shProg = simpleProgram "sh" - progDb = - modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) - emptyProgramDb + progDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb shConfiguredProg <- lookupProgram shProg `fmap` configureProgram verbosity shProg progDb diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 65aa733684f..22933370233 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -697,10 +697,12 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do | otherwise = error "libAbiHash: Can't find an enabled library way" (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcProg comp platform ghcArgs) + =<< ghcInvocation verbosity ghcProg comp platform ghcArgs + return (takeWhile (not . isSpace) hash) componentCcGhcOptions diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 53f78b7e5e6..12860ca104f 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -1769,7 +1769,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcjsProg comp platform ghcArgs) + =<< ghcInvocation verbosity ghcjsProg comp platform ghcArgs return (takeWhile (not . isSpace) hash) componentGhcOptions diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index 1407230b93b..2b20366fadb 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -34,6 +34,7 @@ module Distribution.Simple.Program.Db -- ** Query and manipulate the program db , addKnownProgram , addKnownPrograms + , appendProgramSearchPath , lookupKnownProgram , knownPrograms , getProgramSearchPath @@ -221,6 +222,18 @@ modifyProgramSearchPath modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb' +-- by appending the provided extra paths. Also logs the added paths +-- in info verbosity. +appendProgramSearchPath + :: Verbosity + -> [FilePath] + -> ProgramDb + -> IO ProgramDb +appendProgramSearchPath verbosity extraPaths db = do + logExtraProgramSearchPath verbosity extraPaths + pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) db + -- | User-specify this path. Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it. diff --git a/Cabal/src/Distribution/Simple/Program/Find.hs b/Cabal/src/Distribution/Simple/Program/Find.hs index 73506949e49..4bebe2a19b6 100644 --- a/Cabal/src/Distribution/Simple/Program/Find.hs +++ b/Cabal/src/Distribution/Simple/Program/Find.hs @@ -32,7 +32,9 @@ module Distribution.Simple.Program.Find , defaultProgramSearchPath , findProgramOnSearchPath , programSearchPathAsPATHVar + , logExtraProgramSearchPath , getSystemSearchPath + , getExtraPathEnv , simpleProgram ) where @@ -63,6 +65,15 @@ import qualified System.Win32 as Win32 defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + findProgramOnSearchPath :: Verbosity -> ProgramSearchPath @@ -133,6 +144,25 @@ findProgramOnSearchPath verbosity searchpath prog = do Just _ -> return a Nothing -> firstJustM mas +-- | Adds some paths to the "PATH" entry in the key-value environment provided +-- or if there is none, looks up @$PATH@ in the real environment. +getExtraPathEnv + :: Verbosity + -> [(String, Maybe String)] + -> [FilePath] + -> IO [(String, Maybe String)] +getExtraPathEnv _ _ [] = return [] +getExtraPathEnv verbosity env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + logExtraProgramSearchPath verbosity extras + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@. diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index 537e008c17f..b8b1cc496c7 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -28,6 +28,7 @@ import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.Program.Find (getExtraPathEnv) import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types import Distribution.System @@ -554,8 +555,6 @@ data GhcOptions = GhcOptions , ghcOptExtraPath :: NubListR FilePath -- ^ Put the extra folders in the PATH environment variable we invoke -- GHC with - -- | Put the extra folders in the PATH environment variable we invoke - -- GHC with , ghcOptCabal :: Flag Bool -- ^ Let GHC know that it is Cabal that's calling it. -- Modifies some of the GHC error messages. @@ -616,18 +615,24 @@ runGHC -> GhcOptions -> IO () runGHC verbosity ghcProg comp platform opts = do - runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) + runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts ghcInvocation - :: ConfiguredProgram + :: Verbosity + -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> ProgramInvocation -ghcInvocation prog comp platform opts = - (programInvocation prog (renderGhcOptions comp platform opts)) - { progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) - } + -> IO ProgramInvocation +ghcInvocation verbosity ghcProg comp platform opts = do + -- NOTE: GHC is the only program whose path we modify with more values than + -- the standard @extra-prog-path@, namely the folders of the executables in + -- the components, see @componentGhcOptions@. + let envOverrides = programOverrideEnv ghcProg + extraPath <- getExtraPathEnv verbosity envOverrides (fromNubListR (ghcOptExtraPath opts)) + let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} + + pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts) renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index 27ff33dce01..268cb794505 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/Cabal/src/Distribution/Simple/Program/Run.hs @@ -36,7 +36,6 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Generic import Distribution.Verbosity -import System.FilePath (searchPathSeparator) import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map @@ -51,8 +50,6 @@ data ProgramInvocation = ProgramInvocation { progInvokePath :: FilePath , progInvokeArgs :: [String] , progInvokeEnv :: [(String, Maybe String)] - , -- Extra paths to add to PATH - progInvokePathEnv :: [FilePath] , progInvokeCwd :: Maybe FilePath , progInvokeInput :: Maybe IOData , progInvokeInputEncoding :: IOEncoding @@ -75,7 +72,6 @@ emptyProgramInvocation = { progInvokePath = "" , progInvokeArgs = [] , progInvokeEnv = [] - , progInvokePathEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText @@ -107,7 +103,6 @@ runProgramInvocation { progInvokePath = path , progInvokeArgs = args , progInvokeEnv = [] - , progInvokePathEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing } = @@ -118,12 +113,10 @@ runProgramInvocation { progInvokePath = path , progInvokeArgs = args , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath , progInvokeCwd = mcwd , progInvokeInput = Nothing } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides maybeExit $ rawSystemIOWithEnv verbosity @@ -140,13 +133,11 @@ runProgramInvocation { progInvokePath = path , progInvokeArgs = args , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath , progInvokeCwd = mcwd , progInvokeInput = Just inputStr , progInvokeInputEncoding = encoding } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides (_, errors, exitCode) <- rawSystemStdInOut verbosity @@ -202,30 +193,16 @@ getProgramInvocationIODataAndErrors { progInvokePath = path , progInvokeArgs = args , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath , progInvokeCwd = mcwd , progInvokeInput = minputStr , progInvokeInputEncoding = encoding } mode = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides rawSystemStdInOut verbosity path args mcwd menv input mode where input = encodeToIOData encoding <$> minputStr -getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] -getExtraPathEnv _ [] = return [] -getExtraPathEnv env extras = do - mb_path <- case lookup "PATH" env of - Just x -> return x - Nothing -> lookupEnv "PATH" - let extra = intercalate [searchPathSeparator] extras - path' = case mb_path of - Nothing -> extra - Just path -> extra ++ searchPathSeparator : path - return [("PATH", Just path')] - -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence. diff --git a/Cabal/src/Distribution/Simple/Program/Types.hs b/Cabal/src/Distribution/Simple/Program/Types.hs index 30f35b57a7a..f1b42f63853 100644 --- a/Cabal/src/Distribution/Simple/Program/Types.hs +++ b/Cabal/src/Distribution/Simple/Program/Types.hs @@ -93,6 +93,13 @@ type ProgArg = String -- dir to search after the usual ones. -- -- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +-- We also use this path to set the environment when running child processes. +-- +-- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we +-- @appendProgramSearchPath@ to add the ones that come from cli flags and from +-- configurations. Then each of the programs that are configured in the db +-- inherits the same path as part of @configureProgram@. type ProgramSearchPath = [ProgramSearchPathEntry] data ProgramSearchPathEntry diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index 20a1ee9756e..17396d38a98 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -26,6 +26,10 @@ import Distribution.Client.NixStyleOptions , defaultNixStyleFlags , nixStyleOptions ) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig (projectConfigShared) + , ProjectConfigShared (projectConfigProgPathExtra) + ) import Distribution.Client.ProjectFlags ( removeIgnoreProjectOption ) @@ -72,13 +76,10 @@ import Distribution.Simple.Program , simpleProgram ) import Distribution.Simple.Program.Db - ( configuredPrograms - , modifyProgramSearchPath + ( appendProgramSearchPath + , configuredPrograms , requireProgram ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry (..) - ) import Distribution.Simple.Program.Run ( programInvocation , runProgramInvocation @@ -86,11 +87,13 @@ import Distribution.Simple.Program.Run import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , dieWithException - , info , notice , withTempDirectory , wrapText ) +import Distribution.Utils.NubList + ( fromNubList + ) import Distribution.Verbosity ( normal ) @@ -162,13 +165,15 @@ execAction flags@NixStyleFlags{..} extraArgs globalFlags = do mempty -- Some dependencies may have executables. Let's put those on the PATH. - extraPaths <- pathAdditions verbosity baseCtx buildCtx - let programDb = - modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + let extraPaths = pathAdditions baseCtx buildCtx + + programDb <- + appendProgramSearchPath + verbosity + extraPaths + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx -- Now that we have the packages, set up the environment. We accomplish this -- by creating an environment file that selects the databases and packages we @@ -263,13 +268,15 @@ withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do action envOverrides ) -pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] -pathAdditions verbosity ProjectBaseContext{..} ProjectBuildContext{..} = do - info verbosity . unlines $ - "Including the following directories in PATH:" - : paths - return paths +pathAdditions :: ProjectBaseContext -> ProjectBuildContext -> [FilePath] +pathAdditions ProjectBaseContext{..} ProjectBuildContext{..} = + paths ++ cabalConfigPaths where + cabalConfigPaths = + fromNubList + . projectConfigProgPathExtra + . projectConfigShared + $ projectConfig paths = S.toList $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 5de704430f5..60549656b4d 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -150,14 +150,11 @@ import Distribution.Simple.GHC import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PI import Distribution.Simple.Program.Db - ( defaultProgramDb - , modifyProgramSearchPath + ( appendProgramSearchPath + , defaultProgramDb , userSpecifyArgss , userSpecifyPaths ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry (..) - ) import Distribution.Simple.Setup ( Flag (..) , installDirsOptions @@ -496,6 +493,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt , projectConfigHcPath , projectConfigHcPkg , projectConfigStoreDir + , projectConfigProgPathExtra } , projectConfigLocalPackages = PackageConfig @@ -509,17 +507,13 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg + configProgDb <- appendProgramSearchPath verbosity ((fromNubList packageConfigProgramPathExtra) ++ (fromNubList projectConfigProgPathExtra)) defaultProgramDb + let -- ProgramDb with directly user specified paths preProgDb = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - ( ++ - [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra - ] - ) - $ defaultProgramDb + $ configProgDb -- progDb is a program database with compiler tools configured properly ( compiler@Compiler diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 2ad1b992369..ed66b74aff3 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -48,6 +48,10 @@ import Distribution.Client.NixStyleOptions , defaultNixStyleFlags , nixStyleOptions ) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig (projectConfigShared) + , ProjectConfigShared (projectConfigProgPathExtra) + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) @@ -82,6 +86,12 @@ import Distribution.Simple.Command import Distribution.Simple.Flag ( fromFlagOrDefault ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry (ProgramSearchPathDir) + , defaultProgramSearchPath + , logExtraProgramSearchPath + , programSearchPathAsPATHVar + ) import Distribution.Simple.Program.Run ( ProgramInvocation (..) , emptyProgramInvocation @@ -105,6 +115,9 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.NubList + ( fromNubList + ) import Distribution.Verbosity ( normal , silent @@ -288,6 +301,17 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) + let extraPath = + fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + + logExtraProgramSearchPath verbosity extraPath + + progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) + if dryRun then notice verbosity "Running of executable suppressed by flag(s)" else @@ -297,9 +321,10 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = { progInvokePath = exePath , progInvokeArgs = args , progInvokeEnv = - dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan + ("PATH", Just $ progPath) + : dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan } where (targetStr, args) = splitAt 1 targetAndArgs diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 0fe93081bd7..1c2b4dabb27 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -1540,6 +1540,14 @@ parseConfig src initial = \str -> do splitMultiPath (configConfigureArgs scf) } + , savedGlobalFlags = + let sgf = savedGlobalFlags conf + in sgf + { globalProgPathExtra = + toNubList $ + splitMultiPath + (fromNubList $ globalProgPathExtra sgf) + } } parse = diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index 99ebe749161..39ace2f2652 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -78,6 +78,9 @@ import Distribution.Solver.Types.SourcePackage import Control.Monad (mapM_) import qualified Data.Map as Map import Distribution.Client.Errors +import Distribution.Utils.NubList + ( fromNubList + ) import System.Directory ( createDirectoryIfMissing , doesDirectoryExist @@ -99,7 +102,7 @@ get -> IO () get verbosity _ _ _ [] = notice verbosity "No packages requested. Nothing to do." -get verbosity repoCtxt _ getFlags userTargets = do +get verbosity repoCtxt globalFlags getFlags userTargets = do let useSourceRepo = case getSourceRepository getFlags of NoFlag -> False _ -> True @@ -154,7 +157,7 @@ get verbosity repoCtxt _ getFlags userTargets = do clone :: [UnresolvedSourcePackage] -> IO () clone = - clonePackagesFromSourceRepo verbosity prefix kind + clonePackagesFromSourceRepo verbosity prefix kind (fromNubList $ globalProgPathExtra globalFlags) . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind :: Maybe RepoKind @@ -337,6 +340,8 @@ clonePackagesFromSourceRepo -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind' + -> [FilePath] + -- ^ Extra prog paths -> [(PackageId, [PD.SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's @@ -345,13 +350,14 @@ clonePackagesFromSourceRepo verbosity destDirPrefix preferredRepoKind + progPaths pkgrepos = do -- Do a bunch of checks and collect the required info pkgrepos' <- traverse preCloneChecks pkgrepos -- Configure the VCS drivers for all the repository types we may need vcss <- - configureVCSs verbosity $ + configureVCSs verbosity progPaths $ Map.fromList [ (vcsRepoType vcs, vcs) | (_, _, vcs, _) <- pkgrepos' diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs index 39251039a36..39bd264c744 100644 --- a/cabal-install/src/Distribution/Client/HttpUtils.hs +++ b/cabal-install/src/Distribution/Client/HttpUtils.hs @@ -38,7 +38,6 @@ import Distribution.Simple.Program ( ConfiguredProgram , Program , ProgramInvocation (..) - , ProgramSearchPathEntry (..) , getProgramInvocationOutput , programInvocation , programPath @@ -47,10 +46,10 @@ import Distribution.Simple.Program import Distribution.Simple.Program.Db ( ProgramDb , addKnownPrograms + , appendProgramSearchPath , configureAllKnownPrograms , emptyProgramDb , lookupProgram - , modifyProgramSearchPath , requireProgram ) import Distribution.Simple.Program.Run @@ -409,7 +408,7 @@ configureTransport verbosity extraPath (Just name) = case find (\(name', _, _, _) -> name' == name) supportedTransports of Just (_, mprog, _tls, mkTrans) -> do - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + baseProgDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb progdb <- case mprog of Nothing -> return emptyProgramDb Just prog -> snd <$> requireProgram verbosity prog baseProgDb @@ -425,7 +424,7 @@ configureTransport verbosity extraPath Nothing = do -- for all the transports except plain-http we need to try and find -- their external executable - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + baseProgDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb progdb <- configureAllKnownPrograms verbosity $ addKnownPrograms diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 3083f9777bf..b4d20e317cc 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1351,11 +1351,10 @@ syncAndReadSourcePackagesRemoteRepos | (repo, rloc, rtype, vcs) <- repos' ] - -- TODO: pass progPathExtra on to 'configureVCS' - let _progPathExtra = fromNubList projectConfigProgPathExtra + let progPathExtra = fromNubList projectConfigProgPathExtra getConfiguredVCS <- delayInitSharedResources $ \repoType -> let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs - in configureVCS verbosity {-progPathExtra-} vcs + in configureVCS verbosity progPathExtra vcs concat <$> sequenceA diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index a13d35011b1..db99b2576b9 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -231,7 +231,7 @@ data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplComma deriving (Show, Eq) -- | This holds the context of a project prior to solving: the content of the --- @cabal.project@ and all the local package @.cabal@ files. +-- @cabal.project@, @cabal/config@ and all the local package @.cabal@ files. data ProjectBaseContext = ProjectBaseContext { distDirLayout :: DistDirLayout , cabalDirLayout :: CabalDirLayout diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6d63ffcbaab..06c28105aa3 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -468,13 +468,15 @@ configureCompiler ) $ do liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- + progdb <- liftIO $ appendProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) defaultProgramDb + let progdb' = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) progdb + result@(_, _, progdb'') <- liftIO $ Cabal.configCompilerEx hcFlavor hcPath hcPkg - progdb + progdb' verbosity -- Note that we added the user-supplied program locations and args @@ -483,22 +485,13 @@ configureCompiler -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') + monitorFiles (programsMonitorFiles progdb'') return result where hcFlavor = flagToMaybe projectConfigHcFlavor hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . modifyProgramSearchPath - ( [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra - ] - ++ - ) - $ defaultProgramDb ------------------------------------------------------------------------------ diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 8a9b1c01707..eba9b833d9d 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -88,9 +88,11 @@ import Distribution.Simple.Program , ghcjsProgram , runDbProgram ) +import Distribution.Simple.Program.Db + ( appendProgramSearchPath + ) import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry (ProgramSearchPathDir) - , programSearchPathAsPATHVar + ( programSearchPathAsPATHVar ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment @@ -537,11 +539,11 @@ invoke verbosity path args options = do Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle + progDb <- appendProgramSearchPath verbosity (useExtraPathEnv options) (useProgramDb options) + searchpath <- - programSearchPathAsPATHVar - ( map ProgramSearchPathDir (useExtraPathEnv options) - ++ getProgramSearchPath (useProgramDb options) - ) + programSearchPathAsPATHVar $ getProgramSearchPath progDb + env <- getEffectiveEnvironment $ [ ("PATH", Just searchpath) diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 7322253e692..f3403029827 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -61,6 +61,9 @@ import Distribution.Simple.Program , runProgramInvocation , simpleProgram ) +import Distribution.Simple.Program.Db + ( appendProgramSearchPath + ) import Distribution.Types.SourceRepo ( KnownRepoType (..) , RepoType (..) @@ -198,18 +201,23 @@ validateSourceRepos rs = configureVCS :: Verbosity + -> [FilePath] + -- ^ Extra prog paths -> VCS Program -> IO (VCS ConfiguredProgram) -configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb +configureVCS verbosity progPaths vcs@VCS{vcsProgram = prog} = do + progPath <- appendProgramSearchPath verbosity progPaths emptyProgramDb + asVcsConfigured <$> requireProgram verbosity prog progPath where asVcsConfigured (prog', _) = vcs{vcsProgram = prog'} configureVCSs :: Verbosity + -> [FilePath] + -- ^ Extra prog paths -> Map RepoType (VCS Program) -> IO (Map RepoType (VCS ConfiguredProgram)) -configureVCSs verbosity = traverse (configureVCS verbosity) +configureVCSs verbosity progPaths = traverse (configureVCS verbosity progPaths) -- ------------------------------------------------------------ diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs index 55ce4180f8f..c033c05f93a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs @@ -64,7 +64,7 @@ testNoRepos :: Assertion testNoRepos = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageNoSourceRepos pkgidfoo where pkgrepos = [(pkgidfoo, [])] @@ -73,7 +73,7 @@ testNoReposOfKind :: Assertion testNoReposOfKind = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." repokind pkgrepos + clonePackagesFromSourceRepo verbosity "." repokind [] pkgrepos e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind where pkgrepos = [(pkgidfoo, [repo])] @@ -84,7 +84,7 @@ testNoRepoType :: Assertion testNoRepoType = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageNoRepoType pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] @@ -94,7 +94,7 @@ testUnsupportedRepoType :: Assertion testUnsupportedRepoType = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype where pkgrepos = [(pkgidfoo, [repo])] @@ -118,7 +118,7 @@ testNoRepoLocation :: Assertion testNoRepoLocation = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageNoRepoLocation pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] @@ -139,7 +139,7 @@ testSelectRepoKind = e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo | let test rt rs = assertException $ - clonePackagesFromSourceRepo verbosity "." rt rs + clonePackagesFromSourceRepo verbosity "." rt [] rs , (requestedRepoType, expectedRepo) <- cases ] where @@ -161,14 +161,14 @@ testRepoDestinationExists = createDirectory pkgdir e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -} removeDirectory pkgdir writeFile pkgdir "" e2 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -} where pkgrepos = [(pkgidfoo, [repo])] @@ -199,7 +199,7 @@ testGitFetchFailed = pkgrepos = [(pkgidfoo, [repo])] e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128) testNetworkGitClone :: Assertion @@ -214,6 +214,7 @@ testNetworkGitClone = verbosity tmpdir Nothing + [] [(mkpkgid "zlib1", [repo1])] assertFileContains (tmpdir "zlib1/zlib.cabal") ["name:", "zlib"] @@ -226,6 +227,7 @@ testNetworkGitClone = verbosity tmpdir Nothing + [] [(mkpkgid "zlib2", [repo2])] assertFileContains (tmpdir "zlib2/zlib.cabal") ["name:", "zlib"] @@ -239,6 +241,7 @@ testNetworkGitClone = verbosity tmpdir Nothing + [] [(mkpkgid "zlib3", [repo3])] assertFileContains (tmpdir "zlib3/zlib.cabal") ["version:", "0.5.0.0"] where diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index 64c517c10e9..0bd49355913 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -57,7 +57,7 @@ tests :: MTimeChange -> [TestTree] tests mtimeChange = map (localOption $ QuickCheckTests 10) - [ ignoreInWindows "See issue #8048" $ + [ ignoreInWindows "See issue #8048 and #9519" $ testGroup "git" [ testProperty "check VCS test framework" prop_framework_git @@ -227,7 +227,7 @@ testSetup -> IO a testSetup vcs mkVCSTestDriver repoRecipe theTest = do -- test setup - vcs' <- configureVCS verbosity vcs + vcs' <- configureVCS verbosity [] vcs withTestDir verbosity "vcstest" $ \tmpdir -> do let srcRepoPath = tmpdir "src" submodulesPath = tmpdir "submodules" diff --git a/changelog.d/propagate-extra-prog-path b/changelog.d/propagate-extra-prog-path new file mode 100644 index 00000000000..9938736f7a1 --- /dev/null +++ b/changelog.d/propagate-extra-prog-path @@ -0,0 +1,13 @@ +synopsis: Fix extra-prog-path propagation +packages: cabal-install Cabal +prs: #9527 +issues: #7649 #9519 + +description: { + +- extra-prog-paths are now propagated to all commands. This in particular helps + when running a MinGW cabal in the PowerShell, where the MSYS2 paths are + usually not available in the PowerShell PATH. GHCup already sets them up for + us but they were sometimes lost on the way. + +}