{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE InterruptibleFFI #-}
#endif
module System.Process (
#ifndef __HUGS__
createProcess,
shell, proc,
CreateProcess(..),
CmdSpec(..),
StdStream(..),
ProcessHandle,
callProcess,
callCommand,
spawnProcess,
spawnCommand,
readProcess,
readProcessWithExitCode,
showCommandForUser,
waitForProcess,
getProcessExitCode,
terminateProcess,
interruptProcessGroupOf,
runProcess,
runCommand,
runInteractiveProcess,
runInteractiveCommand,
#endif
system,
rawSystem,
) where
import Prelude hiding (mapM)
#ifndef __HUGS__
import System.Process.Internals
import Control.Exception (SomeException, mask, try, throwIO)
import Control.DeepSeq (rnf)
import System.IO.Error (mkIOError, ioeSetErrorString)
#if !defined(mingw32_HOST_OS)
import System.Posix.Types
import System.Posix.Process (getProcessGroupIDOf)
#endif
import qualified Control.Exception as C
import Control.Concurrent
import Control.Monad
import Foreign
import Foreign.C
import System.IO
import Data.Maybe
#endif
import System.Exit ( ExitCode(..) )
#ifdef __GLASGOW_HASKELL__
import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )
#if defined(mingw32_HOST_OS)
import System.Win32.Process (getProcessId)
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT)
#else
import System.Posix.Signals
#endif
#endif
#ifdef __HUGS__
import Hugs.System
#endif
#ifndef __HUGS__
proc :: FilePath -> [String] -> CreateProcess
proc cmd args = CreateProcess { cmdspec = RawCommand cmd args,
cwd = Nothing,
env = Nothing,
std_in = Inherit,
std_out = Inherit,
std_err = Inherit,
close_fds = False,
create_group = False,
delegate_ctlc = False}
shell :: String -> CreateProcess
shell str = CreateProcess { cmdspec = ShellCommand str,
cwd = Nothing,
env = Nothing,
std_in = Inherit,
std_out = Inherit,
std_err = Inherit,
close_fds = False,
create_group = False,
delegate_ctlc = False}
createProcess
:: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess cp = do
r <- createProcess_ "createProcess" cp
maybeCloseStd (std_in cp)
maybeCloseStd (std_out cp)
maybeCloseStd (std_err cp)
return r
where
maybeCloseStd :: StdStream -> IO ()
maybeCloseStd (UseHandle hdl)
| hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl
maybeCloseStd _ = return ()
withCreateProcess_
:: String
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess_ fun c action =
C.bracketOnError (createProcess_ fun c) cleanupProcess
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
terminateProcess ph
maybe (return ()) (ignoreSigPipe . hClose) mb_stdin
maybe (return ()) hClose mb_stdout
maybe (return ()) hClose mb_stderr
_ <- forkIO (waitForProcess ph >> return ())
return ()
spawnProcess :: FilePath -> [String] -> IO ProcessHandle
spawnProcess cmd args = do
(_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args)
return p
spawnCommand :: String -> IO ProcessHandle
spawnCommand cmd = do
(_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd)
return p
callProcess :: FilePath -> [String] -> IO ()
callProcess cmd args = do
exit_code <- withCreateProcess_ "callCommand"
(proc cmd args) { delegate_ctlc = True } $ \_ _ _ p ->
waitForProcess p
case exit_code of
ExitSuccess -> return ()
ExitFailure r -> processFailedException "callProcess" cmd args r
callCommand :: String -> IO ()
callCommand cmd = do
exit_code <- withCreateProcess_ "callCommand"
(shell cmd) { delegate_ctlc = True } $ \_ _ _ p ->
waitForProcess p
case exit_code of
ExitSuccess -> return ()
ExitFailure r -> processFailedException "callCommand" cmd [] r
processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException fun cmd args exit_code =
ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++
concatMap ((' ':) . show) args ++
" (exit " ++ show exit_code ++ ")")
Nothing Nothing)
readProcess
:: FilePath
-> [String]
-> String
-> IO String
readProcess cmd args input = do
let cp_opts = (proc cmd args) {
std_in = CreatePipe,
std_out = CreatePipe,
std_err = Inherit
}
(ex, output) <- withCreateProcess_ "readProcess" cp_opts $
\(Just inh) (Just outh) _ ph -> do
output <- hGetContents outh
withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
unless (null input) $
ignoreSigPipe $ hPutStr inh input
ignoreSigPipe $ hClose inh
waitOut
hClose outh
ex <- waitForProcess ph
return (ex, output)
case ex of
ExitSuccess -> return output
ExitFailure r -> processFailedException "readProcess" cmd args r
readProcessWithExitCode
:: FilePath
-> [String]
-> String
-> IO (ExitCode,String,String)
readProcessWithExitCode cmd args input = do
let cp_opts = (proc cmd args) {
std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe
}
withCreateProcess_ "readProcessWithExitCode" cp_opts $
\(Just inh) (Just outh) (Just errh) ph -> do
out <- hGetContents outh
err <- hGetContents errh
withForkWait (C.evaluate $ rnf out) $ \waitOut ->
withForkWait (C.evaluate $ rnf err) $ \waitErr -> do
unless (null input) $
ignoreSigPipe $ hPutStr inh input
ignoreSigPipe $ hClose inh
waitOut
waitErr
hClose outh
hClose errh
ex <- waitForProcess ph
return (ex, out, err)
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) `C.onException` killThread tid
ignoreSigPipe :: IO () -> IO ()
#if defined(__GLASGOW_HASKELL__)
ignoreSigPipe = C.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
#else
ignoreSigPipe = id
#endif
showCommandForUser :: FilePath -> [String] -> String
showCommandForUser cmd args = unwords (map translate (cmd : args))
waitForProcess
:: ProcessHandle
-> IO ExitCode
waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_)
case p_ of
ClosedHandle e -> return e
OpenHandle h -> do
e <- alloca $ \pret -> do
throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
modifyProcessHandle ph $ \p_' ->
case p_' of
ClosedHandle e -> return (p_',e)
OpenHandle ph' -> do
closePHANDLE ph'
code <- peek pret
let e = if (code == 0)
then ExitSuccess
else (ExitFailure (fromIntegral code))
return (ClosedHandle e, e)
when delegating_ctlc $
endDelegateControlC e
return e
getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do
(m_e, was_open) <- modifyProcessHandle ph $ \p_ ->
case p_ of
ClosedHandle e -> return (p_, (Just e, False))
OpenHandle h ->
alloca $ \pExitCode -> do
res <- throwErrnoIfMinus1Retry "getProcessExitCode" $
c_getProcessExitCode h pExitCode
code <- peek pExitCode
if res == 0
then return (p_, (Nothing, False))
else do
closePHANDLE h
let e | code == 0 = ExitSuccess
| otherwise = ExitFailure (fromIntegral code)
return (ClosedHandle e, (Just e, True))
case m_e of
Just e | was_open && delegating_ctlc -> endDelegateControlC e
_ -> return ()
return m_e
terminateProcess :: ProcessHandle -> IO ()
terminateProcess ph = do
withProcessHandle ph $ \p_ ->
case p_ of
ClosedHandle _ -> return ()
OpenHandle h -> do
throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h
return ()
interruptProcessGroupOf
:: ProcessHandle
-> IO ()
interruptProcessGroupOf ph = do
withProcessHandle ph $ \p_ -> do
case p_ of
ClosedHandle _ -> return ()
OpenHandle h -> do
#if mingw32_HOST_OS
pid <- getProcessId h
generateConsoleCtrlEvent cTRL_BREAK_EVENT pid
#else
pgid <- getProcessGroupIDOf h
signalProcessGroup sigINT pgid
#endif
return ()
foreign import ccall unsafe "terminateProcess"
c_terminateProcess
:: PHANDLE
-> IO CInt
foreign import ccall unsafe "getProcessExitCode"
c_getProcessExitCode
:: PHANDLE
-> Ptr CInt
-> IO CInt
foreign import ccall interruptible "waitForProcess"
c_waitForProcess
:: PHANDLE
-> Ptr CInt
-> IO CInt
runCommand
:: String
-> IO ProcessHandle
runCommand string = do
(_,_,_,ph) <- createProcess_ "runCommand" (shell string)
return ph
runProcess
:: FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String,String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do
(_,_,_,ph) <-
createProcess_ "runProcess"
(proc cmd args){ cwd = mb_cwd,
env = mb_env,
std_in = mbToStd mb_stdin,
std_out = mbToStd mb_stdout,
std_err = mbToStd mb_stderr }
maybeClose mb_stdin
maybeClose mb_stdout
maybeClose mb_stderr
return ph
where
maybeClose :: Maybe Handle -> IO ()
maybeClose (Just hdl)
| hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl
maybeClose _ = return ()
mbToStd :: Maybe Handle -> StdStream
mbToStd Nothing = Inherit
mbToStd (Just hdl) = UseHandle hdl
runInteractiveCommand
:: String
-> IO (Handle,Handle,Handle,ProcessHandle)
runInteractiveCommand string =
runInteractiveProcess1 "runInteractiveCommand" (shell string)
runInteractiveProcess
:: FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String,String)]
-> IO (Handle,Handle,Handle,ProcessHandle)
runInteractiveProcess cmd args mb_cwd mb_env = do
runInteractiveProcess1 "runInteractiveProcess"
(proc cmd args){ cwd = mb_cwd, env = mb_env }
runInteractiveProcess1
:: String
-> CreateProcess
-> IO (Handle,Handle,Handle,ProcessHandle)
runInteractiveProcess1 fun cmd = do
(mb_in, mb_out, mb_err, p) <-
createProcess_ fun
cmd{ std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe }
return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
#endif /* !__HUGS__ */
#ifdef __GLASGOW_HASKELL__
system :: String -> IO ExitCode
system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
system str = do
(_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True }
waitForProcess p
#endif /* __GLASGOW_HASKELL__ */
rawSystem :: String -> [String] -> IO ExitCode
#ifdef __GLASGOW_HASKELL__
rawSystem cmd args = do
(_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True }
waitForProcess p
#elif !mingw32_HOST_OS
rawSystem cmd args = system (showCommandForUser cmd args)
#elif __HUGS__
rawSystem cmd args = system (cmd ++ showCommandForUser "" args)
#else
rawSystem cmd args = system (showCommandForUser cmd args)
#endif