Restructure modules
This commit is contained in:
362
lib/GHCup/Prelude/Process/Posix.hs
Normal file
362
lib/GHCup/Prelude/Process/Posix.hs
Normal file
@@ -0,0 +1,362 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE CApiFFI #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Posix
|
||||
Description : Process handling for unix
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Prelude.Process.Posix where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.File.Posix
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import qualified Control.Exception as E
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Foldable
|
||||
import Data.IORef
|
||||
import Data.Sequence ( Seq, (|>) )
|
||||
import Data.List
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import System.IO ( stderr )
|
||||
import System.IO.Error hiding ( catchIOError )
|
||||
import System.FilePath
|
||||
import System.Posix.Directory
|
||||
import System.Posix.IO
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.Posix.Process as SPP
|
||||
import qualified System.Console.Terminal.Size as TP
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> m CapturedProcess
|
||||
executeOut path args chdir = liftIO $ captureOutStreams $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile path True args Nothing
|
||||
|
||||
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
Settings {..} <- getSettings
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let logfile = fromGHCupPath logsDir </> lfile <> ".log"
|
||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||
closeFd
|
||||
(action verbose noColor)
|
||||
where
|
||||
action verbose no_color fd = do
|
||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||
-- start the thread that logs to stdout
|
||||
pState <- newEmptyMVar
|
||||
done <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ EX.finally
|
||||
(if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6 pState no_color
|
||||
)
|
||||
(putMVar done ())
|
||||
|
||||
-- fork the subprocess
|
||||
pid <- SPP.forkProcess $ do
|
||||
void $ dupTo stdoutWrite stdOutput
|
||||
void $ dupTo stdoutWrite stdError
|
||||
closeFd stdoutRead
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
||||
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- wait for the subprocess to finish
|
||||
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
|
||||
putMVar pState (either (const False) (const True) e)
|
||||
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
closeFd stdoutRead
|
||||
|
||||
pure e
|
||||
|
||||
tee :: Fd -> Fd -> IO ()
|
||||
tee fileFd = readTilEOF lineAction
|
||||
|
||||
where
|
||||
lineAction :: ByteString -> IO ()
|
||||
lineAction bs' = do
|
||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
||||
|
||||
-- Reads fdIn and logs the output in a continous scrolling area
|
||||
-- of 'size' terminal lines. Also writes to a log file.
|
||||
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
|
||||
printToRegion fileFd fdIn size pState no_color = do
|
||||
-- init region
|
||||
forM_ [1..size] $ \_ -> BS.hPut stderr "\n"
|
||||
|
||||
void $ flip runStateT mempty
|
||||
$ do
|
||||
handle
|
||||
(\(ex :: SomeException) -> do
|
||||
ps <- liftIO $ takeMVar pState
|
||||
when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))
|
||||
throw ex
|
||||
) $ readTilEOF lineAction fdIn
|
||||
|
||||
where
|
||||
clearScreen :: ByteString
|
||||
clearScreen = "\x1b[0J"
|
||||
clearLine :: ByteString
|
||||
clearLine = "\x1b[2K"
|
||||
moveLineUp :: Int -> ByteString
|
||||
moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"
|
||||
moveLineDown :: Int -> ByteString
|
||||
moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"
|
||||
pos1 :: ByteString
|
||||
pos1 = "\r"
|
||||
overwriteNthLine :: Int -> ByteString -> ByteString
|
||||
overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
|
||||
|
||||
blue :: ByteString -> ByteString
|
||||
blue bs
|
||||
| no_color = bs
|
||||
| otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
|
||||
|
||||
-- action to perform line by line
|
||||
lineAction :: (MonadMask m, MonadIO m)
|
||||
=> ByteString
|
||||
-> StateT (Seq ByteString) m ()
|
||||
lineAction = \bs' -> do
|
||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
modify (swapRegs bs')
|
||||
liftIO TP.size >>= \case
|
||||
Nothing -> pure ()
|
||||
Just (TP.Window _ w) -> do
|
||||
regs <- get
|
||||
liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
|
||||
BS.hPut stderr
|
||||
. overwriteNthLine (size - i)
|
||||
. trim w
|
||||
. blue
|
||||
. (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
|
||||
$ bs
|
||||
|
||||
swapRegs :: a -> Seq a -> Seq a
|
||||
swapRegs bs = \regs -> if
|
||||
| Sq.length regs < size -> regs |> bs
|
||||
| otherwise -> Sq.drop 1 regs |> bs
|
||||
|
||||
-- trim output line to terminal width
|
||||
trim :: Int -> ByteString -> ByteString
|
||||
trim w = \bs -> if
|
||||
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
||||
| otherwise -> bs
|
||||
|
||||
-- Consecutively read from Fd in 512 chunks until we hit
|
||||
-- newline or EOF.
|
||||
readLine :: MonadIO m
|
||||
=> Fd -- ^ input file descriptor
|
||||
-> ByteString -- ^ rest buffer (read across newline)
|
||||
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
||||
readLine fd = go
|
||||
where
|
||||
go inBs = do
|
||||
-- if buffer is not empty, process it first
|
||||
mbs <- if BS.length inBs == 0
|
||||
-- otherwise attempt read
|
||||
then liftIO
|
||||
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
|
||||
$ fmap Just
|
||||
$ SPIB.fdRead fd 512
|
||||
else pure $ Just inBs
|
||||
case mbs of
|
||||
Nothing -> pure ("", "", True)
|
||||
Just bs -> do
|
||||
-- split on newline
|
||||
let (line, rest) = BS.span (/= _lf) bs
|
||||
if
|
||||
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
|
||||
-- if rest is empty, then there was no newline, process further
|
||||
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
||||
|
||||
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
||||
readTilEOF ~action' fd' = go mempty
|
||||
where
|
||||
go bs' = do
|
||||
(bs, rest, eof) <- readLine fd' bs'
|
||||
if eof
|
||||
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
||||
else void (action' bs) >> go rest
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
-- is run in a subprocess. Stdin is closed. You might want to
|
||||
-- 'race' this to make sure it terminates.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action = do
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPP.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
a <- action
|
||||
void $ E.evaluate a
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
-- start thread that writes the output
|
||||
refOut <- newIORef BL.empty
|
||||
refErr <- newIORef BL.empty
|
||||
done <- newEmptyMVar
|
||||
_ <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||
|
||||
status <- SPP.getProcessStatus True True pid
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
|
||||
case status of
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPP.Exited es) -> do
|
||||
stdout' <- readIORef refOut
|
||||
stderr' <- readIORef refErr
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
|
||||
_ -> throwIO $ userError ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
|
||||
writeStds pout perr rout rerr = do
|
||||
doneOut <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneOut ())
|
||||
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
|
||||
doneErr <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneErr ())
|
||||
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
|
||||
takeMVar doneOut
|
||||
takeMVar doneErr
|
||||
|
||||
readTilEOF ~action' fd' = do
|
||||
bs <- SPIB.fdRead fd' 512
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
|
||||
|
||||
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
|
||||
|
||||
cleanup :: [Fd] -> IO ()
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> FilePath -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: MonadIO m
|
||||
=> String -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
exec exe args chdir env = liftIO $ do
|
||||
pid <- SPP.forkProcess $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [String]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
|
||||
Just (SPP.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
|
||||
251
lib/GHCup/Prelude/Process/Windows.hs
Normal file
251
lib/GHCup/Prelude/Process/Windows.hs
Normal file
@@ -0,0 +1,251 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Process.Windows
|
||||
Description : Process handling for windows
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : Windows
|
||||
-}
|
||||
module GHCup.Prelude.Process.Windows where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude.File.Search
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
import Foreign.C.Error
|
||||
import GHC.IO.Exception
|
||||
import GHC.IO.Handle
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import System.Process
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [FilePath]
|
||||
-> ExitCode
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args exitcode = case exitcode of
|
||||
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
|
||||
ExitSuccess -> Right ()
|
||||
|
||||
|
||||
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
|
||||
-- lets you pass 'CreateProcess' giving better flexibility.
|
||||
--
|
||||
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
|
||||
-- record will be ignored.
|
||||
--
|
||||
-- @since 1.2.3.0
|
||||
readCreateProcessWithExitCodeBS
|
||||
:: CreateProcess
|
||||
-> BL.ByteString
|
||||
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
|
||||
readCreateProcessWithExitCodeBS cp input = do
|
||||
let cp_opts = cp {
|
||||
std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = CreatePipe
|
||||
}
|
||||
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
|
||||
\mb_inh mb_outh mb_errh ph ->
|
||||
case (mb_inh, mb_outh, mb_errh) of
|
||||
(Just inh, Just outh, Just errh) -> do
|
||||
|
||||
out <- BS.hGetContents outh
|
||||
err <- BS.hGetContents errh
|
||||
|
||||
-- fork off threads to start consuming stdout & stderr
|
||||
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
|
||||
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
|
||||
|
||||
-- now write any input
|
||||
unless (BL.null input) $
|
||||
ignoreSigPipe $ BL.hPut inh input
|
||||
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
|
||||
ignoreSigPipe $ hClose inh
|
||||
|
||||
-- wait on the output
|
||||
waitOut
|
||||
waitErr
|
||||
|
||||
hClose outh
|
||||
hClose errh
|
||||
|
||||
-- wait on the process
|
||||
ex <- waitForProcess ph
|
||||
return (ex, BL.fromStrict out, BL.fromStrict err)
|
||||
|
||||
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
|
||||
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
|
||||
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
|
||||
where
|
||||
ignoreSigPipe :: IO () -> IO ()
|
||||
ignoreSigPipe = EX.handle $ \e -> case e of
|
||||
IOError { ioe_type = ResourceVanished
|
||||
, ioe_errno = Just ioe }
|
||||
| Errno ioe == ePIPE -> return ()
|
||||
_ -> throwIO e
|
||||
-- wrapper so we can get exceptions with the appropriate function name.
|
||||
withCreateProcess_
|
||||
:: String
|
||||
-> CreateProcess
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> IO a
|
||||
withCreateProcess_ fun c action =
|
||||
EX.bracketOnError (createProcess_ fun c) cleanupProcess
|
||||
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
|
||||
|
||||
-- | Fork a thread while doing something else, but kill it if there's an
|
||||
-- exception.
|
||||
--
|
||||
-- This is important in the cases above because we want to kill the thread
|
||||
-- that is holding the Handle lock, because when we clean up the process we
|
||||
-- try to close that handle, which could otherwise deadlock.
|
||||
--
|
||||
withForkWait :: IO () -> (IO () -> IO a) -> IO a
|
||||
withForkWait async' body = do
|
||||
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
|
||||
mask $ \restore -> do
|
||||
tid <- forkIO $ try (restore async') >>= putMVar waitVar
|
||||
let wait' = takeMVar waitVar >>= either throwIO return
|
||||
restore (body wait') `EX.onException` killThread tid
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> m CapturedProcess
|
||||
executeOut path args chdir = do
|
||||
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
|
||||
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
|
||||
cp <- createProcessWithMingwPath ((proc exe args)
|
||||
{ cwd = chdir
|
||||
, env = env
|
||||
, std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
})
|
||||
fmap (toProcessError exe args)
|
||||
$ liftIO
|
||||
$ withCreateProcess cp
|
||||
$ \_ mout merr ph ->
|
||||
case (mout, merr) of
|
||||
(Just cStdout, Just cStderr) -> do
|
||||
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
|
||||
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
|
||||
waitOut
|
||||
waitErr
|
||||
waitForProcess ph
|
||||
_ -> fail "Could not acquire out/err handle"
|
||||
|
||||
where
|
||||
tee :: FilePath -> Handle -> IO ()
|
||||
tee logFile handle' = go
|
||||
where
|
||||
go = do
|
||||
some <- BS.hGetSome handle' 512
|
||||
if BS.null some
|
||||
then pure ()
|
||||
else do
|
||||
void $ BS.appendFile logFile some
|
||||
-- subprocess stdout also goes to stderr for logging
|
||||
void $ BS.hPut stderr some
|
||||
go
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
exec exe args chdir env = do
|
||||
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError exe args exit_code
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
execShell :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execShell exe args chdir env = do
|
||||
let cmd = exe <> " " <> concatMap (' ':) args
|
||||
cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError cmd [] exit_code
|
||||
|
||||
|
||||
createProcessWithMingwPath :: MonadIO m
|
||||
=> CreateProcess
|
||||
-> m CreateProcess
|
||||
createProcessWithMingwPath cp = do
|
||||
msys2Dir <- liftIO ghcupMsys2Dir
|
||||
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
|
||||
let mingWPaths = [msys2Dir </> "usr" </> "bin"
|
||||
,msys2Dir </> "mingw64" </> "bin"]
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
envWithNewPath = Map.insert "Path" newPath envWithoutPath
|
||||
liftIO $ setEnv "Path" newPath
|
||||
pure $ cp { env = Just $ Map.toList envWithNewPath }
|
||||
|
||||
ghcupMsys2Dir :: IO FilePath
|
||||
ghcupMsys2Dir =
|
||||
lookupEnv "GHCUP_MSYS2" >>= \case
|
||||
Just fp -> pure fp
|
||||
Nothing -> do
|
||||
baseDir <- liftIO ghcupBaseDir
|
||||
pure (fromGHCupPath baseDir </> "msys64")
|
||||
|
||||
Reference in New Issue
Block a user