diff --git a/rio/src/RIO/Process.hs b/rio/src/RIO/Process.hs index 3628727..2c214ee 100644 --- 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,10 +288,6 @@ 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 @@ -298,6 +295,14 @@ mkProcessContext tm' = do 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 index 98ba240..04fe916 100644 --- 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