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.

Author: jasagredo

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

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

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 =

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'

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

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

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

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"

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.
+
+}