diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index 74e5f857..1d4e365c 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -20,7 +20,7 @@ import GHCup.Prelude import GHCup.Prelude.File #ifdef IS_WINDOWS import GHCup.Prelude.Process -import GHCup.Prelude.Process.Windows ( execNoMinGW ) +import GHCup.Prelude.Process.Windows ( execNoMinGW, resolveExecutable ) #endif import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ @@ -32,7 +32,7 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Functor -import Data.Maybe (isNothing) +import Data.Maybe (isNothing, fromMaybe) import Data.List ( intercalate ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) @@ -268,9 +268,10 @@ run RunOptions{..} runAppState leanAppstate runLogger = do void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) pure ExitSuccess #else + resolvedCmd <- fmap (fromMaybe cmd) $ liftIO $ resolveExecutable cmd runMinGWPath r' <- if runMinGWPath - then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) - else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv) + then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec resolvedCmd args Nothing (Just newEnv) + else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW resolvedCmd args Nothing (Just newEnv) case r' of VRight _ -> pure ExitSuccess VLeft e -> do diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs index 47fc5e9f..bb1301c5 100644 --- a/lib/GHCup/Prelude/Process/Windows.hs +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -32,6 +32,7 @@ import System.Environment import System.FilePath import System.IO import System.Process +import System.Win32.Info (getSystemDirectory, getWindowsDirectory) import qualified Control.Exception as EX import qualified Data.ByteString as BS @@ -219,6 +220,28 @@ exec exe args chdir env' = do exit_code <- liftIO $ withRestorePath (env cp) $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p pure $ toProcessError exe args exit_code + +-- See: +-- - https://github.com/haskell/ghcup-hs/issues/1106 +-- - https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375#note_435793 +-- +-- We emulate the logic of 'CreateProcessW' described under the parameter +-- 'lpApplicationName': https://learn.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-createprocessw#parameters +-- ...while NOT considering the directory from which the application is loaded (which is C:/ghcup/bin) +resolveExecutable :: FilePath -> Bool -> IO (Maybe FilePath) +resolveExecutable fp minGW + | length (splitPath fp) /= 1 = pure $ Just fp + | otherwise = do + system32Dir <- getSystemDirectory + windowsDir <- getWindowsDirectory + curDir <- getCurrentDirectory + let system16Dir = windowsDir "System" + mingWPaths <- if minGW then ghcupMsys2BinDirs' else pure [] + path <- getSearchPath + let withExtension = if hasExtension fp then fp else fp <.> "exe" + searchPath (curDir:system32Dir:system16Dir:windowsDir:(mingWPaths ++ path)) withExtension + + -- | Like 'exec', except doesn't add msys2 stuff to PATH. execNoMinGW :: MonadIO m => FilePath -- ^ thing to execute