Fix augment path

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`

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

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

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