From 50a61e8d16ddd31cc8e1a17933459b37b3149632 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. This allows finding system executables in: - `cabal exec` - `cabal build` (configure steps for example) - `cabal get` In particular this fixes PATH issues when running MinGW cabal in PowerShell. --- .../src/Distribution/Client/CmdExec.hs | 15 ++++++++++++- .../src/Distribution/Client/CmdRun.hs | 15 +++++++++++++ .../src/Distribution/Client/Config.hs | 8 +++++++ cabal-install/src/Distribution/Client/Get.hs | 13 +++++++++--- .../src/Distribution/Client/ProjectConfig.hs | 5 ++--- cabal-install/src/Distribution/Client/VCS.hs | 16 +++++++++++--- .../UnitTests/Distribution/Client/Get.hs | 21 +++++++++++-------- .../UnitTests/Distribution/Client/VCS.hs | 4 ++-- changelog.d/propagate-extra-prog-path | 13 ++++++++++++ 9 files changed, 89 insertions(+), 21 deletions(-) create mode 100644 changelog.d/propagate-extra-prog-path diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index 3a3dd306d8a..63ae176a38d 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 ) @@ -91,6 +95,9 @@ import Distribution.Simple.Utils , withTempDirectory , wrapText ) +import Distribution.Utils.NubList + ( fromNubList + ) import Distribution.Verbosity ( normal ) @@ -163,9 +170,15 @@ execAction flags@NixStyleFlags{..} extraArgs globalFlags = do -- Some dependencies may have executables. Let's put those on the PATH. extraPaths <- pathAdditions verbosity baseCtx buildCtx + let configProgPathExtras = + fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx let programDb = modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) + (map ProgramSearchPathDir (configProgPathExtras ++ extraPaths) ++) . pkgConfigCompilerProgs . elaboratedShared $ buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 2ad1b992369..e5e058b96ab 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 (..) @@ -105,6 +109,9 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.NubList + ( fromNubList + ) import Distribution.Verbosity ( normal , silent @@ -288,6 +295,13 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) + let extraPath = + fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + if dryRun then notice verbosity "Running of executable suppressed by flag(s)" else @@ -300,6 +314,7 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = dataDirsEnvironmentForPlan (distDirLayout baseCtx) elaboratedPlan + , progInvokePathEnv = extraPath } 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 1a1fcfbb388..1344ae59a07 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -1539,6 +1539,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..0d30e3dd006 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,15 @@ 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 $ + -- TODO: the empty list below should have the config prog paths + configureVCSs verbosity progPaths $ Map.fromList [ (vcsRepoType vcs, vcs) | (_, _, vcs, _) <- pkgrepos' 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/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 7322253e692..0bcfc887f42 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -61,6 +61,12 @@ import Distribution.Simple.Program , runProgramInvocation , simpleProgram ) +import Distribution.Simple.Program.Db + ( modifyProgramSearchPath + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry (ProgramSearchPathDir) + ) import Distribution.Types.SourceRepo ( KnownRepoType (..) , RepoType (..) @@ -198,18 +204,22 @@ validateSourceRepos rs = configureVCS :: Verbosity + -> [FilePath] -> VCS Program + -- ^ Extra prog paths -> IO (VCS ConfiguredProgram) -configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb +configureVCS verbosity progPaths vcs@VCS{vcsProgram = prog} = + asVcsConfigured <$> requireProgram verbosity prog (modifyProgramSearchPath (map ProgramSearchPathDir progPaths ++) emptyProgramDb) where asVcsConfigured (prog', _) = vcs{vcsProgram = prog'} configureVCSs :: Verbosity + -> [FilePath] -> Map RepoType (VCS Program) + -- ^ Extra prog paths -> 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..7733ed7633f --- /dev/null +++ b/changelog.d/propagate-extra-prog-path @@ -0,0 +1,13 @@ +synopsis: Fix extra-prog-path propagation +packages: cabal-install +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 not being propagated properly. + +}