hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix windows process creation handling wrt #1036

Browse Source
This commit is contained in:
Julian Ospald 2024-04-07 18:07:01 +08:00
parent be4a1bdf7a
commit b37ac53aaf
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
1 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
lib/GHCup/Prelude/Process/Windows.hs
View File

@ -150,7 +150,7 @@ executeOut' :: MonadIO m
-> m CapturedProcess -> m CapturedProcess
executeOut' path args chdir env' = do executeOut' path args chdir env' = do
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' }) cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' })
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" (exit, out, err) <- liftIO $ withRestorePath (env cp) $ readCreateProcessWithExitCodeBS cp ""
pure $ CapturedProcess exit out err pure $ CapturedProcess exit out err
@ -166,20 +166,21 @@ execLogged :: ( MonadReader env m
-> FilePath -- ^ log filename (opened in append mode) -> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env' = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log" let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log" stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args) cp <- createProcessWithMingwPath ((proc exe args)
{ cwd = chdir { cwd = chdir
, env = env , env = env'
, std_in = CreatePipe , std_in = CreatePipe
, std_out = CreatePipe , std_out = CreatePipe
, std_err = CreatePipe , std_err = CreatePipe
}) })
fmap (toProcessError exe args) fmap (toProcessError exe args)
$ liftIO $ liftIO
$ withRestorePath (env cp)
$ withCreateProcess cp $ withCreateProcess cp
$ \_ mout merr ph -> $ \_ mout merr ph ->
case (mout, merr) of case (mout, merr) of
@ -213,16 +214,9 @@ exec :: MonadIO m
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
exec exe args chdir env = do exec exe args chdir env' = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375 cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env' })
forM_ (Map.fromList <$> env) $ \cEnv -> do exit_code <- liftIO $ withRestorePath (env cp) $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code pure $ toProcessError exe args exit_code
-- | Like 'exec', except doesn't add msys2 stuff to PATH. -- | Like 'exec', except doesn't add msys2 stuff to PATH.
@ -233,13 +227,6 @@ execNoMinGW :: MonadIO m
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execNoMinGW exe args chdir env = do execNoMinGW exe args chdir env = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
let cp = (proc exe args) { cwd = chdir, env = env } let cp = (proc exe args) { cwd = chdir, env = env }
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code pure $ toProcessError exe args exit_code
@ -270,7 +257,27 @@ createProcessWithMingwPath cp = do
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
envWithNewPath = Map.insert "Path" newPath envWithoutPath envWithNewPath = Map.insert "Path" newPath envWithoutPath
liftIO $ setEnv "Path" newPath
pure $ cp { env = Just $ Map.toList envWithNewPath } pure $ cp { env = Just $ Map.toList envWithNewPath }
withRestorePath :: MonadIO m => Maybe [(String, String)] -- ^ optional env we want to extract 'PATH' from
-> m a -- ^ action to perform
-> m a
withRestorePath env action = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
oldPATH <- liftIO $ lookupEnv "PATH"
oldPath <- liftIO $ lookupEnv "Path"
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
liftIO $ print newPath
r <- action
liftIO $ maybe (unsetEnv "PATH") (setEnv "PATH") oldPATH
liftIO $ maybe (unsetEnv "Path") (setEnv "Path") oldPath
pure r