Merge pull request #237 from hasufell/jospald/fix-augment-path

Fix augment path
commercialhaskell · Aug 9, 2021 · e724637 · e724637
2 parents 983a0f5 + f62145e
commit e724637
Show file tree

Hide file tree

Showing 4 changed files with 52 additions and 9 deletions.
diff --git a/rio/ChangeLog.md b/rio/ChangeLog.md
@@ -1,5 +1,9 @@
 # Changelog for rio
 
+## 0.1.21.0
+
+* Fix minor bug in `augmentPathMap` on windows wrt [#234](https://github.com/commercialhaskell/rio/issues/234) not adhering to case-insensitive semantics
+
 ## 0.1.20.0
 
 * Export `UnliftIO.QSem` and `UnliftIO.QSemN` in `RIO`

diff --git a/rio/package.yaml b/rio/package.yaml
@@ -1,5 +1,5 @@
 name: rio
-version: 0.1.20.0
+version: 0.1.21.0
 synopsis: A standard library for Haskell
 description: See README and Haddocks at <https://www.stackage.org/package/rio>
 license: MIT
@@ -122,3 +122,6 @@ tests:
  - rio
  - hspec
  - QuickCheck
+ verbatim: |
+ build-tool-depends:
+ hspec-discover:hspec-discover
diff --git a/rio/src/RIO/Process.hs b/rio/src/RIO/Process.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Interacting with external processes.
 --
@@ -190,7 +191,7 @@ data ProcessException
  | ExecutableNotFound String [FilePath]
  | ExecutableNotFoundAt FilePath
  | PathsInvalidInPath [FilePath]
- deriving Typeable
+ deriving (Typeable, Eq)
 instance Show ProcessException where
  show NoPathFound = "PATH not found in ProcessContext"
  show (ExecutableNotFound name path) = concat
@@ -269,7 +270,7 @@ exeSearchPathL = processContextL.to pcPath
 --
 -- @since 0.0.3.0
 mkProcessContext :: MonadIO m => EnvVars -> m ProcessContext
-mkProcessContext tm' = do
+mkProcessContext (normalizePathEnv -> tm) = do
  ref <- newIORef Map.empty
  return ProcessContext
  { pcTextMap = tm
@@ -287,17 +288,21 @@ mkProcessContext tm' = do
  , pcWorkingDir = Nothing
  }
  where
- -- Fix case insensitivity of the PATH environment variable on Windows.
- tm
- | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'
- | otherwise = tm'
  -- Default value for PATHTEXT on Windows versions after Windows XP. (The
  -- documentation of the default at
  -- https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/start
  -- is incomplete.)
  defaultPATHEXT = ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"
 
 
+-- Fix case insensitivity of the PATH environment variable on Windows,
+-- by forcing all keys full uppercase.
+normalizePathEnv :: EnvVars -> EnvVars
+normalizePathEnv env
+ | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList env
+ | otherwise = env
+
+
 -- | Reset the executable cache.
 --
 -- @since 0.0.3.0
@@ -654,7 +659,8 @@ exeExtensions = do
  pc <- view processContextL
  return $ pcExeExtensions pc
 
--- | Augment the PATH environment variable with the given extra paths.
+-- | Augment the PATH environment variable with the given extra paths,
+-- which are prepended (as in: they take precedence).
 --
 -- @since 0.0.3.0
 augmentPath :: [FilePath] -> Maybe Text -> Either ProcessException Text
@@ -670,7 +676,7 @@ augmentPath dirs mpath =
 --
 -- @since 0.0.3.0
 augmentPathMap :: [FilePath] -> EnvVars -> Either ProcessException EnvVars
-augmentPathMap dirs origEnv =
+augmentPathMap dirs (normalizePathEnv -> origEnv) =
  do path <- augmentPath dirs mpath
  return $ Map.insert "PATH" path origEnv
  where

diff --git a/rio/test/RIO/Prelude/ExtraSpec.hs b/rio/test/RIO/Prelude/ExtraSpec.hs
@@ -1,8 +1,16 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module RIO.Prelude.ExtraSpec (spec) where
 
 import RIO
+import RIO.Process
 import Test.Hspec
 
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import qualified System.FilePath as FP
+
 spec :: Spec
 spec = do
  describe "foldMapM" $ do
@@ -11,3 +19,25 @@ spec = do
  helper = pure . pure
  res <- foldMapM helper [1..10]
  res `shouldBe` [1..10]
+ describe "augmentPathMap" $ do
+ -- https://github.com/commercialhaskell/rio/issues/234
+ it "Doesn't duplicate PATH keys on windows" $ do
+ let pathKey :: T.Text
+#if WINDOWS
+ pathKey = "Path"
+#else
+ pathKey = "PATH"
+#endif
+ origEnv :: EnvVars
+ origEnv = Map.fromList [ ("foo", "3")
+ , ("bar", "baz")
+ , (pathKey, makePath ["/local/bin", "/usr/bin"])
+ ]
+ let res = second (fmap getPaths . Map.lookup "PATH") $ augmentPathMap ["/bin"] origEnv
+ res `shouldBe` Right (Just ["/bin", "/local/bin", "/usr/bin"])
+ where
+ makePath :: [T.Text] -> T.Text
+ makePath = T.intercalate (T.singleton FP.searchPathSeparator)
+
+ getPaths :: T.Text -> [T.Text]
+ getPaths = fmap T.pack . FP.splitSearchPath . T.unpack