Merge pull request haskell#10827 from haskell/wip/duplicate-env-vars

Fix environment variable handling when running executables

Author: mergify[bot]

Cabal/src/Distribution/Simple/Bench.hs

@@ -22,7 +22,6 @@ module Distribution.Simple.Bench
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Compat.Environment
 import qualified Distribution.PackageDescription as PD
 import Distribution.Pretty
 import Distribution.Simple.Build (addInternalBuildTools)
@@ -89,15 +88,12 @@ bench args pkg_descr lbi flags = do
               dieWithException verbosity $
                 NoBenchMarkProgram cmd
 
-            existingEnv <- getEnvironment
-
             -- Compute the appropriate environment for running the benchmark
             let progDb = LBI.withPrograms lbiForBench
                 pathVar = progSearchPath progDb
                 envOverrides = progOverrideEnv progDb
             newPath <- programSearchPathAsPATHVar pathVar
-            overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
-            let shellEnv = overrideEnv ++ existingEnv
+            shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides)
 
             -- Add (DY)LD_LIBRARY_PATH if needed
             shellEnv' <-

Cabal/src/Distribution/Simple/Program/Run.hs

@@ -29,6 +29,7 @@ module Distribution.Simple.Program.Run
   , getProgramInvocationOutputAndErrors
   , getProgramInvocationLBSAndErrors
   , getEffectiveEnvironment
+  , getFullEnvironment
   ) where
 
 import Distribution.Compat.Prelude
@@ -237,6 +238,12 @@ getProgramInvocationIODataAndErrors
 -- | Return the current environment extended with the given overrides.
 -- If an entry is specified twice in @overrides@, the second entry takes
 -- precedence.
+--
+-- getEffectiveEnvironment returns 'Nothing' when there are no overrides.
+-- It returns an argument that is suitable to pass directly to 'CreateProcess' to
+-- override the environment.
+-- If you need the full environment to manipulate further, even when there are no overrides,
+-- then call 'getFullEnvironment'.
 getEffectiveEnvironment
   :: [(String, Maybe String)]
   -> IO (Maybe [(String, String)])
@@ -248,6 +255,17 @@ getEffectiveEnvironment overrides =
     update (var, Nothing) = Map.delete var
     update (var, Just val) = Map.insert var val
 
+-- | Like 'getEffectiveEnvironment', but when no overrides are specified,
+-- returns the full environment instead of 'Nothing'.
+getFullEnvironment
+  :: [(String, Maybe String)]
+  -> IO [(String, String)]
+getFullEnvironment overrides = do
+  menv <- getEffectiveEnvironment overrides
+  case menv of
+    Just env -> return env
+    Nothing -> getEnvironment
+
 -- | Like the unix xargs program. Useful for when we've got very long command
 -- lines that might overflow an OS limit on command line length and so you
 -- need to invoke a command multiple times to get all the args in.

Cabal/src/Distribution/Simple/Test/ExeV10.hs

@@ -8,7 +8,6 @@ module Distribution.Simple.Test.ExeV10
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Compat.Environment
 import qualified Distribution.PackageDescription as PD
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
@@ -64,8 +63,6 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
       way = guessWay lbi
       tixDir_ = i $ tixDir distPref way
 
-  existingEnv <- getEnvironment
-
   let cmd =
         i (LBI.buildDir lbi)
           </> testName'
@@ -92,13 +89,18 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
       pathVar = progSearchPath progDb
       envOverrides = progOverrideEnv progDb
   newPath <- programSearchPathAsPATHVar pathVar
-  overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
   let opts =
         map
           (testOption pkg_descr lbi suite)
           (testOptions flags)
       tixFile = packageRoot (testCommonFlags flags) </> getSymbolicPath (tixFilePath distPref way (testName'))
-      shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ overrideEnv ++ existingEnv
+
+  shellEnv <-
+    getFullEnvironment
+      ( [("PATH", Just newPath)]
+          ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]
+          ++ envOverrides
+      )
 
   -- Add (DY)LD_LIBRARY_PATH if needed
   shellEnv' <-

Cabal/src/Distribution/Simple/Test/LibV09.hs

@@ -17,7 +17,6 @@ import Distribution.Compat.Prelude
 import Distribution.Types.UnqualComponentName
 import Prelude ()
 
-import Distribution.Compat.Environment
 import Distribution.Compat.Internal.TempFile
 import Distribution.Compat.Process (proc)
 import Distribution.ModuleName
@@ -70,7 +69,6 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
       way = guessWay lbi
 
   let mbWorkDir = LBI.mbWorkDirLBI lbi
-  existingEnv <- getEnvironment
 
   let cmd =
         interpretSymbolicPath mbWorkDir (LBI.buildDir lbi)
@@ -100,15 +98,17 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
         pathVar = progSearchPath progDb
         envOverrides = progOverrideEnv progDb
     newPath <- programSearchPathAsPATHVar pathVar
-    overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
 
     -- Run test executable
     let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
         tixFile = i $ tixFilePath distPref way testName'
-        shellEnv =
-          [("HPCTIXFILE", tixFile) | isCoverageEnabled]
-            ++ overrideEnv
-            ++ existingEnv
+
+    shellEnv <-
+      getFullEnvironment
+        ( [("PATH", Just newPath)]
+            ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]
+            ++ envOverrides
+        )
     -- Add (DY)LD_LIBRARY_PATH if needed
     shellEnv' <-
       if LBI.withDynExe lbi

cabal-install/src/Distribution/Client/Run.hs

@@ -59,7 +59,6 @@ import Distribution.Types.UnqualComponentName
 import qualified Distribution.Simple.GHCJS as GHCJS
 
 import Distribution.Client.Errors
-import Distribution.Compat.Environment (getEnvironment)
 import Distribution.Utils.Path
 
 -- | Return the executable to run and any extra arguments that should be
@@ -178,13 +177,11 @@ run verbosity lbi exe exeArgs = do
             return (p, [])
 
   -- Compute the appropriate environment for running the executable
-  existingEnv <- getEnvironment
   let progDb = withPrograms lbiForExe
       pathVar = progSearchPath progDb
       envOverrides = progOverrideEnv progDb
   newPath <- programSearchPathAsPATHVar pathVar
-  overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
-  let env = overrideEnv ++ existingEnv
+  env <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides)
 
   -- Add (DY)LD_LIBRARY_PATH if needed
   env' <-

cabal-testsuite/PackageTests/DuplicateEnvVars/cabal.out

@@ -0,0 +1 @@
+packages: p

cabal-testsuite/PackageTests/DuplicateEnvVars/cabal.project

@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+
+main = cabalTest $ recordMode DoNotRecord $ do
+    res <- cabal' "test" ["all"]
+    assertOutputContains "No duplicate environment variables found" res

cabal-testsuite/PackageTests/DuplicateEnvVars/cabal.test.hs

@@ -0,0 +1,16 @@
+module Main where
+
+import Data.List (group, sort)
+import System.Environment (getEnvironment)
+
+main = do
+    env <- getEnvironment
+    let sortedEnv = sort env
+        duplicates = filter (\g -> length g > 1) $ group $ map fst sortedEnv
+
+    if null duplicates
+        then putStrLn "No duplicate environment variables found."
+        else do
+            putStrLn "Found duplicate environment variables:"
+            mapM_ (\d -> putStrLn $ "  - " ++ head d) duplicates
+            fail "Test failed due to duplicate environment variables"

cabal-testsuite/PackageTests/DuplicateEnvVars/p/Main.hs

@@ -0,0 +1,10 @@
+cabal-version:      3.0
+name:               p
+version:            0.1.0.0
+build-type:         Simple
+
+test-suite env-test
+    default-language: Haskell2010
+    type:             exitcode-stdio-1.0
+    main-is:          Main.hs
+    build-depends:    base