diff --git a/System/Process.hs b/System/Process.hs new file mode 100644 --- /dev/null +++ b/System/Process.hs @@ -0,0 +1,876 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE InterruptibleFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Process +-- Copyright : (c) The University of Glasgow 2004-2008 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- Operations for creating and interacting with sub-processes. +-- +----------------------------------------------------------------------------- + +-- ToDo: +-- * Flag to control whether exiting the parent also kills the child. + +module System.Process ( + -- * Running sub-processes + createProcess, + createProcess_, + shell, proc, + CreateProcess(..), + CmdSpec(..), + StdStream(..), + ProcessHandle, + + -- ** Simpler functions for common tasks + callProcess, + callCommand, + spawnProcess, + spawnCommand, + readCreateProcess, + readProcess, + readCreateProcessWithExitCode, + readProcessWithExitCode, + withCreateProcess, + + -- ** Related utilities + showCommandForUser, + + -- ** Control-C handling on Unix + -- $ctlc-handling + + -- * Process completion + waitForProcess, + getProcessExitCode, + terminateProcess, + interruptProcessGroupOf, + + -- Interprocess communication + createPipe, + createPipeFd, + + -- * Old deprecated functions + -- | These functions pre-date 'createProcess' which is much more + -- flexible. + runProcess, + runCommand, + runInteractiveProcess, + runInteractiveCommand, + system, + rawSystem, + ) where + +import Prelude hiding (mapM) + +import System.Process.Internals + +import Control.Concurrent +import Control.DeepSeq (rnf) +import Control.Exception (SomeException, mask, try, throwIO) +import qualified Control.Exception as C +import Control.Monad +import Data.Maybe +import Foreign +import Foreign.C +import System.Exit ( ExitCode(..) ) +import System.IO +import System.IO.Error (mkIOError, ioeSetErrorString) + +-- Provide the data constructors for CPid on GHC 7.4 and later +#if !defined(WINDOWS) && MIN_VERSION_base(4,5,0) +import System.Posix.Types (CPid (..)) +#endif + +import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) + +-- ---------------------------------------------------------------------------- +-- createProcess + +-- | Construct a 'CreateProcess' record for passing to 'createProcess', +-- representing a raw command with arguments. +-- +-- See 'RawCommand' for precise semantics of the specified @FilePath@. +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, + detach_console = False, + create_new_console = False, + new_session = False, + child_group = Nothing, + child_user = Nothing } + +-- | Construct a 'CreateProcess' record for passing to 'createProcess', +-- representing a command to be passed to the shell. +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, + detach_console = False, + create_new_console = False, + new_session = False, + child_group = Nothing, + child_user = Nothing } + +{- | +This is the most general way to spawn an external process. The +process can be a command line to be executed by a shell or a raw command +with a list of arguments. The stdin, stdout, and stderr streams of +the new process may individually be attached to new pipes, to existing +'Handle's, or just inherited from the parent (the default.) + +The details of how to create the process are passed in the +'CreateProcess' record. To make it easier to construct a +'CreateProcess', the functions 'proc' and 'shell' are supplied that +fill in the fields with default values which can be overriden as +needed. + +'createProcess' returns @(/mb_stdin_hdl/, /mb_stdout_hdl/, /mb_stderr_hdl/, /ph/)@, +where + + * if @'std_in' == 'CreatePipe'@, then @/mb_stdin_hdl/@ will be @Just /h/@, + where @/h/@ is the write end of the pipe connected to the child + process's @stdin@. + + * otherwise, @/mb_stdin_hdl/ == Nothing@ + +Similarly for @/mb_stdout_hdl/@ and @/mb_stderr_hdl/@. + +For example, to execute a simple @ls@ command: + +> r <- createProcess (proc "ls" []) + +To create a pipe from which to read the output of @ls@: + +> (_, Just hout, _, _) <- +> createProcess (proc "ls" []){ std_out = CreatePipe } + +To also set the directory in which to run @ls@: + +> (_, Just hout, _, _) <- +> createProcess (proc "ls" []){ cwd = Just "\home\bob", +> std_out = CreatePipe } + +Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the +@UseHandle@ constructor will be closed by calling this function. This is not +always the desired behavior. In cases where you would like to leave the +@Handle@ open after spawning the child process, please use 'createProcess_' +instead. + +-} +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 () + +{- +-- | A 'C.bracket'-style resource handler for 'createProcess'. +-- +-- Does automatic cleanup when the action finishes. If there is an exception +-- in the body then it ensures that the process gets terminated and any +-- 'CreatePipe' 'Handle's are closed. In particular this means that if the +-- Haskell thread is killed (e.g. 'killThread'), that the external process is +-- also terminated. +-- +-- e.g. +-- +-- > withCreateProcess (proc cmd args) { ... } $ \_ _ _ ph -> do +-- > ... +-- +-- @since 1.4.3.0 +-} +withCreateProcess + :: CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a +withCreateProcess c action = + C.bracket (createProcess c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + +-- 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 = + 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@(ProcessHandle _ delegating_ctlc)) = do + terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + -- terminateProcess does not guarantee that it terminates the process. + -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee + -- that it stops. If it doesn't stop, we don't want to hang, so we wait + -- asynchronously using forkIO. + + -- However we want to end the Ctl-C handling synchronously, so we'll do + -- that synchronously, and set delegating_ctlc as False for the + -- waitForProcess (which would otherwise end the Ctl-C delegation itself). + when delegating_ctlc + stopDelegateControlC + _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) + return () + where + resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False + +-- ---------------------------------------------------------------------------- +-- spawnProcess/spawnCommand + +-- | Creates a new process to run the specified raw command with the given +-- arguments. It does not wait for the program to finish, but returns the +-- 'ProcessHandle'. +-- +-- @since 1.2.0.0 +spawnProcess :: FilePath -> [String] -> IO ProcessHandle +spawnProcess cmd args = do + (_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args) + return p + +-- | Creates a new process to run the specified shell command. +-- It does not wait for the program to finish, but returns the 'ProcessHandle'. +-- +-- @since 1.2.0.0 +spawnCommand :: String -> IO ProcessHandle +spawnCommand cmd = do + (_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd) + return p + + +-- ---------------------------------------------------------------------------- +-- callProcess/callCommand + +-- | Creates a new process to run the specified command with the given +-- arguments, and wait for it to finish. If the command returns a non-zero +-- exit code, an exception is raised. +-- +-- If an asynchronous exception is thrown to the thread executing +-- @callProcess@, the forked process will be terminated and +-- @callProcess@ will wait (block) until the process has been +-- terminated. +-- +-- @since 1.2.0.0 +callProcess :: FilePath -> [String] -> IO () +callProcess cmd args = do + exit_code <- withCreateProcess_ "callProcess" + (proc cmd args) { delegate_ctlc = True } $ \_ _ _ p -> + waitForProcess p + case exit_code of + ExitSuccess -> return () + ExitFailure r -> processFailedException "callProcess" cmd args r + +-- | Creates a new process to run the specified shell command. If the +-- command returns a non-zero exit code, an exception is raised. +-- +-- If an asynchronous exception is thrown to the thread executing +-- @callCommand@, the forked process will be terminated and +-- @callCommand@ will wait (block) until the process has been +-- terminated. +-- +-- @since 1.2.0.0 +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) + + +-- ---------------------------------------------------------------------------- +-- Control-C handling on Unix + +-- $ctlc-handling +-- +-- When running an interactive console process (such as a shell, console-based +-- text editor or ghci), we typically want that process to be allowed to handle +-- Ctl-C keyboard interrupts how it sees fit. For example, while most programs +-- simply quit on a Ctl-C, some handle it specially. To allow this to happen, +-- use the @'delegate_ctlc' = True@ option in the 'CreateProcess' options. +-- +-- The gory details: +-- +-- By default Ctl-C will generate a @SIGINT@ signal, causing a 'UserInterrupt' +-- exception to be sent to the main Haskell thread of your program, which if +-- not specially handled will terminate the program. Normally, this is exactly +-- what is wanted: an orderly shutdown of the program in response to Ctl-C. +-- +-- Of course when running another interactive program in the console then we +-- want to let that program handle Ctl-C. Under Unix however, Ctl-C sends +-- @SIGINT@ to every process using the console. The standard solution is that +-- while running an interactive program, ignore @SIGINT@ in the parent, and let +-- it be handled in the child process. If that process then terminates due to +-- the @SIGINT@ signal, then at that point treat it as if we had recieved the +-- @SIGINT@ ourselves and begin an orderly shutdown. +-- +-- This behaviour is implemented by 'createProcess' (and +-- 'waitForProcess' \/ 'getProcessExitCode') when the @'delegate_ctlc' = True@ +-- option is set. In particular, the @SIGINT@ signal will be ignored until +-- 'waitForProcess' returns (or 'getProcessExitCode' returns a non-Nothing +-- result), so it becomes especially important to use 'waitForProcess' for every +-- processes created. +-- +-- In addition, in 'delegate_ctlc' mode, 'waitForProcess' and +-- 'getProcessExitCode' will throw a 'UserInterrupt' exception if the process +-- terminated with @'ExitFailure' (-SIGINT)@. Typically you will not want to +-- catch this exception, but let it propagate, giving a normal orderly shutdown. +-- One detail to be aware of is that the 'UserInterrupt' exception is thrown +-- /synchronously/ in the thread that calls 'waitForProcess', whereas normally +-- @SIGINT@ causes the exception to be thrown /asynchronously/ to the main +-- thread. +-- +-- For even more detail on this topic, see +-- . + +-- ----------------------------------------------------------------------------- + +-- | @readProcess@ forks an external process, reads its standard output +-- strictly, blocking until the process terminates, and returns the output +-- string. The external process inherits the standard error. +-- +-- If an asynchronous exception is thrown to the thread executing +-- @readProcess@, the forked process will be terminated and @readProcess@ will +-- wait (block) until the process has been terminated. +-- +-- Output is returned strictly, so this is not suitable for +-- interactive applications. +-- +-- This function throws an 'IOError' if the process 'ExitCode' is +-- anything other than 'ExitSuccess'. If instead you want to get the +-- 'ExitCode' then use 'readProcessWithExitCode'. +-- +-- Users of this function should compile with @-threaded@ if they +-- want other Haskell threads to keep running while waiting on +-- the result of readProcess. +-- +-- > > readProcess "date" [] [] +-- > "Thu Feb 7 10:03:39 PST 2008\n" +-- +-- The arguments are: +-- +-- * The command to run, which must be in the $PATH, or an absolute or relative path +-- +-- * A list of separate command line arguments to the program +-- +-- * A string to pass on standard input to the forked process. +-- +readProcess + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO String -- ^ stdout +readProcess cmd args = readCreateProcess $ proc cmd args + +-- | @readCreateProcess@ works exactly like 'readProcess' except that it +-- lets you pass 'CreateProcess' giving better flexibility. +-- +-- > > readCreateProcess (shell "pwd" { cwd = "/etc/" }) "" +-- > "/etc\n" +-- +-- Note that @Handle@s provided for @std_in@ or @std_out@ via the CreateProcess +-- record will be ignored. +-- +-- @since 1.2.3.0 + +readCreateProcess + :: CreateProcess + -> String -- ^ standard input + -> IO String -- ^ stdout +readCreateProcess cp input = do + let cp_opts = cp { + std_in = CreatePipe, + std_out = CreatePipe + } + (ex, output) <- withCreateProcess_ "readCreateProcess" cp_opts $ + \(Just inh) (Just outh) _ ph -> do + + -- fork off a thread to start consuming the output + output <- hGetContents outh + withForkWait (C.evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + hClose outh + + -- wait on the process + ex <- waitForProcess ph + return (ex, output) + + case ex of + ExitSuccess -> return output + ExitFailure r -> processFailedException "readCreateProcess" cmd args r + where + cmd = case cp of + CreateProcess { cmdspec = ShellCommand sc } -> sc + CreateProcess { cmdspec = RawCommand fp _ } -> fp + args = case cp of + CreateProcess { cmdspec = ShellCommand _ } -> [] + CreateProcess { cmdspec = RawCommand _ args' } -> args' + + +-- | @readProcessWithExitCode@ is like @readProcess@ but with two differences: +-- +-- * it returns the 'ExitCode' of the process, and does not throw any +-- exception if the code is not 'ExitSuccess'. +-- +-- * it reads and returns the output from process' standard error handle, +-- rather than the process inheriting the standard error handle. +-- +-- On Unix systems, see 'waitForProcess' for the meaning of exit codes +-- when the process died as the result of a signal. +-- +readProcessWithExitCode + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr +readProcessWithExitCode cmd args = + readCreateProcessWithExitCode $ proc cmd args + +-- | @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 +readCreateProcessWithExitCode + :: CreateProcess + -> String -- ^ standard input + -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode cp input = do + let cp_opts = cp { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $ + \(Just inh) (Just outh) (Just errh) ph -> do + + out <- hGetContents outh + err <- hGetContents errh + + -- fork off threads to start consuming stdout & stderr + withForkWait (C.evaluate $ rnf out) $ \waitOut -> + withForkWait (C.evaluate $ rnf err) $ \waitErr -> do + + -- now write any input + unless (null input) $ + ignoreSigPipe $ hPutStr 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, out, err) + +-- | 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) `C.onException` killThread tid + +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = C.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + +-- ---------------------------------------------------------------------------- +-- showCommandForUser + +-- | Given a program @/p/@ and arguments @/args/@, +-- @showCommandForUser /p/ /args/@ returns a string suitable for pasting +-- into @\/bin\/sh@ (on Unix systems) or @CMD.EXE@ (on Windows). +showCommandForUser :: FilePath -> [String] -> String +showCommandForUser cmd args = unwords (map translate (cmd : args)) + + +-- ---------------------------------------------------------------------------- +-- waitForProcess + +{- | Waits for the specified process to terminate, and returns its exit code. + +GHC Note: in order to call @waitForProcess@ without blocking all the +other threads in the system, you must compile the program with +@-threaded@. + +(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ +indicates that the child was terminated by signal @/signum/@. +The signal numbers are platform-specific, so to test for a specific signal use +the constants provided by "System.Posix.Signals" in the @unix@ package. +Note: core dumps are not reported, use "System.Posix.Process" if you need this +detail. + +-} +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 + -- don't hold the MVar while we call c_waitForProcess... + -- (XXX but there's a small race window here during which another + -- thread could close the handle or call waitForProcess) + 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 + +{- | +This is a non-blocking version of 'waitForProcess'. If the process is +still running, 'Nothing' is returned. If the process has exited, then +@'Just' e@ is returned where @e@ is the exit code of the process. + +On Unix systems, see 'waitForProcess' for the meaning of exit codes +when the process died as the result of a signal. +-} + +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 + +-- | Attempts to terminate the specified process. This function should +-- not be used under normal circumstances - no guarantees are given regarding +-- how cleanly the process is terminated. To check whether the process +-- has indeed terminated, use 'getProcessExitCode'. +-- +-- On Unix systems, 'terminateProcess' sends the process the SIGTERM signal. +-- On Windows systems, the Win32 @TerminateProcess@ function is called, passing +-- an exit code of 1. +-- +-- Note: on Windows, if the process was a shell command created by +-- 'createProcess' with 'shell', or created by 'runCommand' or +-- 'runInteractiveCommand', then 'terminateProcess' will only +-- terminate the shell, not the command itself. On Unix systems, both +-- processes are in a process group and will be terminated together. + +terminateProcess :: ProcessHandle -> IO () +terminateProcess ph = do + withProcessHandle ph $ \p_ -> + case p_ of + ClosedHandle _ -> return () + OpenHandle h -> do + throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h + return () + -- does not close the handle, we might want to try terminating it + -- again, or get its exit code. + + +-- ---------------------------------------------------------------------------- +-- Interface to C bits + +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" -- NB. safe - can block + c_waitForProcess + :: PHANDLE + -> Ptr CInt + -> IO CInt + + +-- ---------------------------------------------------------------------------- +-- Old deprecated variants +-- ---------------------------------------------------------------------------- + +-- TODO: We're not going to mark these functions as DEPRECATED immediately in +-- process-1.2.0.0. That's because some of their replacements have not been +-- around for all that long. But they should eventually be marked with a +-- suitable DEPRECATED pragma after a release or two. + + +-- ---------------------------------------------------------------------------- +-- runCommand + +--TODO: in a later release {-# DEPRECATED runCommand "Use 'spawnCommand' instead" #-} + +{- | Runs a command using the shell. + -} +runCommand + :: String + -> IO ProcessHandle + +runCommand string = do + (_,_,_,ph) <- createProcess_ "runCommand" (shell string) + return ph + + +-- ---------------------------------------------------------------------------- +-- runProcess + +--TODO: in a later release {-# DEPRECATED runProcess "Use 'spawnProcess' or 'createProcess' instead" #-} + +{- | Runs a raw command, optionally specifying 'Handle's from which to + take the @stdin@, @stdout@ and @stderr@ channels for the new + process (otherwise these handles are inherited from the current + process). + + Any 'Handle's passed to 'runProcess' are placed immediately in the + closed state. + + Note: consider using the more general 'createProcess' instead of + 'runProcess'. +-} +runProcess + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> Maybe Handle -- ^ Handle to use for @stdin@ (Nothing => use existing @stdin@) + -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) + -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) + -> 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 + +--TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} + +{- | Runs a command using the shell, and returns 'Handle's that may + be used to communicate with the process via its @stdin@, @stdout@, + and @stderr@ respectively. The 'Handle's are initially in binary + mode; if you need them to be in text mode then use 'hSetBinaryMode'. +-} +runInteractiveCommand + :: String + -> IO (Handle,Handle,Handle,ProcessHandle) + +runInteractiveCommand string = + runInteractiveProcess1 "runInteractiveCommand" (shell string) + + +-- ---------------------------------------------------------------------------- +-- runInteractiveProcess + +--TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} + +{- | Runs a raw command, and returns 'Handle's that may be used to communicate + with the process via its @stdin@, @stdout@ and @stderr@ respectively. + + For example, to start a process and feed a string to its stdin: + +> (inp,out,err,pid) <- runInteractiveProcess "..." +> forkIO (hPutStr inp str) + + The 'Handle's are initially in binary mode; if you need them to be + in text mode then use 'hSetBinaryMode'. +-} +runInteractiveProcess + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> 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) + + +-- --------------------------------------------------------------------------- +-- system & rawSystem + +--TODO: in a later release {-# DEPRECATED system "Use 'callCommand' (or 'spawnCommand' and 'waitForProcess') instead" #-} + +{-| +Computation @system cmd@ returns the exit code produced when the +operating system runs the shell command @cmd@. + +This computation may fail with one of the following +'System.IO.Error.IOErrorType' exceptions: + +[@PermissionDenied@] +The process has insufficient privileges to perform the operation. + +[@ResourceExhausted@] +Insufficient resources are available to perform the operation. + +[@UnsupportedOperation@] +The implementation does not support system calls. + +On Windows, 'system' passes the command to the Windows command +interpreter (@CMD.EXE@ or @COMMAND.COM@), hence Unixy shell tricks +will not work. + +On Unix systems, see 'waitForProcess' for the meaning of exit codes +when the process died as the result of a signal. +-} +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 + + +--TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} + +{-| +The computation @'rawSystem' /cmd/ /args/@ runs the operating system command +@/cmd/@ in such a way that it receives as arguments the @/args/@ strings +exactly as given, with no funny escaping or shell meta-syntax expansion. +It will therefore behave more portably between operating systems than 'system'. + +The return codes and possible failures are the same as for 'system'. +-} +rawSystem :: String -> [String] -> IO ExitCode +rawSystem cmd args = do + (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } + waitForProcess p diff --git a/System/Process.hsc b/System/Process.hsc deleted file mode 100644 --- a/System/Process.hsc +++ /dev/null @@ -1,876 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} -#else -{-# LANGUAGE Trustworthy #-} -#endif -{-# LANGUAGE InterruptibleFFI #-} - ------------------------------------------------------------------------------ --- | --- Module : System.Process --- Copyright : (c) The University of Glasgow 2004-2008 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (requires concurrency) --- --- Operations for creating and interacting with sub-processes. --- ------------------------------------------------------------------------------ - --- ToDo: --- * Flag to control whether exiting the parent also kills the child. - -module System.Process ( - -- * Running sub-processes - createProcess, - createProcess_, - shell, proc, - CreateProcess(..), - CmdSpec(..), - StdStream(..), - ProcessHandle, - - -- ** Simpler functions for common tasks - callProcess, - callCommand, - spawnProcess, - spawnCommand, - readCreateProcess, - readProcess, - readCreateProcessWithExitCode, - readProcessWithExitCode, - - -- ** Related utilities - showCommandForUser, - - -- ** Control-C handling on Unix - -- $ctlc-handling - - -- * Process completion - waitForProcess, - getProcessExitCode, - terminateProcess, - interruptProcessGroupOf, - - -- Interprocess communication - createPipe, - createPipeFd, - - -- * Old deprecated functions - -- | These functions pre-date 'createProcess' which is much more - -- flexible. - runProcess, - runCommand, - runInteractiveProcess, - runInteractiveCommand, - system, - rawSystem, - ) where - -import Prelude hiding (mapM) - -import System.Process.Internals - -import Control.Concurrent -import Control.DeepSeq (rnf) -import Control.Exception (SomeException, mask, try, throwIO) -import qualified Control.Exception as C -import Control.Monad -import Data.Maybe -import Foreign -import Foreign.C -import System.Exit ( ExitCode(..) ) -import System.IO -import System.IO.Error (mkIOError, ioeSetErrorString) - --- Provide the data constructors for CPid on GHC 7.4 and later -#if !defined(WINDOWS) && MIN_VERSION_base(4,5,0) -import System.Posix.Types (CPid (..)) -#endif - -import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) - --- ---------------------------------------------------------------------------- --- createProcess - --- | Construct a 'CreateProcess' record for passing to 'createProcess', --- representing a raw command with arguments. --- --- See 'RawCommand' for precise semantics of the specified @FilePath@. -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, - detach_console = False, - create_new_console = False, - new_session = False, - child_group = Nothing, - child_user = Nothing } - --- | Construct a 'CreateProcess' record for passing to 'createProcess', --- representing a command to be passed to the shell. -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, - detach_console = False, - create_new_console = False, - new_session = False, - child_group = Nothing, - child_user = Nothing } - -{- | -This is the most general way to spawn an external process. The -process can be a command line to be executed by a shell or a raw command -with a list of arguments. The stdin, stdout, and stderr streams of -the new process may individually be attached to new pipes, to existing -'Handle's, or just inherited from the parent (the default.) - -The details of how to create the process are passed in the -'CreateProcess' record. To make it easier to construct a -'CreateProcess', the functions 'proc' and 'shell' are supplied that -fill in the fields with default values which can be overriden as -needed. - -'createProcess' returns @(/mb_stdin_hdl/, /mb_stdout_hdl/, /mb_stderr_hdl/, /ph/)@, -where - - * if @'std_in' == 'CreatePipe'@, then @/mb_stdin_hdl/@ will be @Just /h/@, - where @/h/@ is the write end of the pipe connected to the child - process's @stdin@. - - * otherwise, @/mb_stdin_hdl/ == Nothing@ - -Similarly for @/mb_stdout_hdl/@ and @/mb_stderr_hdl/@. - -For example, to execute a simple @ls@ command: - -> r <- createProcess (proc "ls" []) - -To create a pipe from which to read the output of @ls@: - -> (_, Just hout, _, _) <- -> createProcess (proc "ls" []){ std_out = CreatePipe } - -To also set the directory in which to run @ls@: - -> (_, Just hout, _, _) <- -> createProcess (proc "ls" []){ cwd = Just "\home\bob", -> std_out = CreatePipe } - -Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the -@UseHandle@ constructor will be closed by calling this function. This is not -always the desired behavior. In cases where you would like to leave the -@Handle@ open after spawning the child process, please use 'createProcess_' -instead. - --} -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 () - -{- --- TODO: decide if we want to expose this to users --- | A 'C.bracketOnError'-style resource handler for 'createProcess'. --- --- In normal operation it adds nothing, you are still responsible for waiting --- for (or forcing) process termination and closing any 'Handle's. It only does --- automatic cleanup if there is an exception. If there is an exception in the --- body then it ensures that the process gets terminated and any 'CreatePipe' --- 'Handle's are closed. In particular this means that if the Haskell thread --- is killed (e.g. 'killThread'), that the external process is also terminated. --- --- e.g. --- --- > withCreateProcess (proc cmd args) { ... } $ \_ _ _ ph -> do --- > ... --- -withCreateProcess - :: CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) - -> IO a -withCreateProcess c action = - C.bracketOnError (createProcess c) cleanupProcess - (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) --} - --- 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 = - 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@(ProcessHandle _ delegating_ctlc)) = do - terminateProcess ph - -- Note, it's important that other threads that might be reading/writing - -- these handles also get killed off, since otherwise they might be holding - -- the handle lock and prevent us from closing, leading to deadlock. - maybe (return ()) (ignoreSigPipe . hClose) mb_stdin - maybe (return ()) hClose mb_stdout - maybe (return ()) hClose mb_stderr - -- terminateProcess does not guarantee that it terminates the process. - -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee - -- that it stops. If it doesn't stop, we don't want to hang, so we wait - -- asynchronously using forkIO. - - -- However we want to end the Ctl-C handling synchronously, so we'll do - -- that synchronously, and set delegating_ctlc as False for the - -- waitForProcess (which would otherwise end the Ctl-C delegation itself). - when delegating_ctlc - stopDelegateControlC - _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) - return () - where - resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False - --- ---------------------------------------------------------------------------- --- spawnProcess/spawnCommand - --- | Creates a new process to run the specified raw command with the given --- arguments. It does not wait for the program to finish, but returns the --- 'ProcessHandle'. --- --- @since 1.2.0.0 -spawnProcess :: FilePath -> [String] -> IO ProcessHandle -spawnProcess cmd args = do - (_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args) - return p - --- | Creates a new process to run the specified shell command. --- It does not wait for the program to finish, but returns the 'ProcessHandle'. --- --- @since 1.2.0.0 -spawnCommand :: String -> IO ProcessHandle -spawnCommand cmd = do - (_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd) - return p - - --- ---------------------------------------------------------------------------- --- callProcess/callCommand - --- | Creates a new process to run the specified command with the given --- arguments, and wait for it to finish. If the command returns a non-zero --- exit code, an exception is raised. --- --- If an asynchronous exception is thrown to the thread executing --- @callProcess@, the forked process will be terminated and --- @callProcess@ will wait (block) until the process has been --- terminated. --- --- @since 1.2.0.0 -callProcess :: FilePath -> [String] -> IO () -callProcess cmd args = do - exit_code <- withCreateProcess_ "callProcess" - (proc cmd args) { delegate_ctlc = True } $ \_ _ _ p -> - waitForProcess p - case exit_code of - ExitSuccess -> return () - ExitFailure r -> processFailedException "callProcess" cmd args r - --- | Creates a new process to run the specified shell command. If the --- command returns a non-zero exit code, an exception is raised. --- --- If an asynchronous exception is thrown to the thread executing --- @callCommand@, the forked process will be terminated and --- @callCommand@ will wait (block) until the process has been --- terminated. --- --- @since 1.2.0.0 -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) - - --- ---------------------------------------------------------------------------- --- Control-C handling on Unix - --- $ctlc-handling --- --- When running an interactive console process (such as a shell, console-based --- text editor or ghci), we typically want that process to be allowed to handle --- Ctl-C keyboard interrupts how it sees fit. For example, while most programs --- simply quit on a Ctl-C, some handle it specially. To allow this to happen, --- use the @'delegate_ctlc' = True@ option in the 'CreateProcess' options. --- --- The gory details: --- --- By default Ctl-C will generate a @SIGINT@ signal, causing a 'UserInterrupt' --- exception to be sent to the main Haskell thread of your program, which if --- not specially handled will terminate the program. Normally, this is exactly --- what is wanted: an orderly shutdown of the program in response to Ctl-C. --- --- Of course when running another interactive program in the console then we --- want to let that program handle Ctl-C. Under Unix however, Ctl-C sends --- @SIGINT@ to every process using the console. The standard solution is that --- while running an interactive program, ignore @SIGINT@ in the parent, and let --- it be handled in the child process. If that process then terminates due to --- the @SIGINT@ signal, then at that point treat it as if we had recieved the --- @SIGINT@ ourselves and begin an orderly shutdown. --- --- This behaviour is implemented by 'createProcess' (and --- 'waitForProcess' \/ 'getProcessExitCode') when the @'delegate_ctlc' = True@ --- option is set. In particular, the @SIGINT@ signal will be ignored until --- 'waitForProcess' returns (or 'getProcessExitCode' returns a non-Nothing --- result), so it becomes especially important to use 'waitForProcess' for every --- processes created. --- --- In addition, in 'delegate_ctlc' mode, 'waitForProcess' and --- 'getProcessExitCode' will throw a 'UserInterrupt' exception if the process --- terminated with @'ExitFailure' (-SIGINT)@. Typically you will not want to --- catch this exception, but let it propagate, giving a normal orderly shutdown. --- One detail to be aware of is that the 'UserInterrupt' exception is thrown --- /synchronously/ in the thread that calls 'waitForProcess', whereas normally --- @SIGINT@ causes the exception to be thrown /asynchronously/ to the main --- thread. --- --- For even more detail on this topic, see --- . - --- ----------------------------------------------------------------------------- - --- | @readProcess@ forks an external process, reads its standard output --- strictly, blocking until the process terminates, and returns the output --- string. The external process inherits the standard error. --- --- If an asynchronous exception is thrown to the thread executing --- @readProcess@, the forked process will be terminated and @readProcess@ will --- wait (block) until the process has been terminated. --- --- Output is returned strictly, so this is not suitable for --- interactive applications. --- --- This function throws an 'IOError' if the process 'ExitCode' is --- anything other than 'ExitSuccess'. If instead you want to get the --- 'ExitCode' then use 'readProcessWithExitCode'. --- --- Users of this function should compile with @-threaded@ if they --- want other Haskell threads to keep running while waiting on --- the result of readProcess. --- --- > > readProcess "date" [] [] --- > "Thu Feb 7 10:03:39 PST 2008\n" --- --- The arguments are: --- --- * The command to run, which must be in the $PATH, or an absolute or relative path --- --- * A list of separate command line arguments to the program --- --- * A string to pass on standard input to the forked process. --- -readProcess - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> IO String -- ^ stdout -readProcess cmd args = readCreateProcess $ proc cmd args - --- | @readCreateProcess@ works exactly like 'readProcess' except that it --- lets you pass 'CreateProcess' giving better flexibility. --- --- > > readCreateProcess (shell "pwd" { cwd = "/etc/" }) "" --- > "/etc\n" --- --- Note that @Handle@s provided for @std_in@ or @std_out@ via the CreateProcess --- record will be ignored. --- --- @since 1.2.3.0 - -readCreateProcess - :: CreateProcess - -> String -- ^ standard input - -> IO String -- ^ stdout -readCreateProcess cp input = do - let cp_opts = cp { - std_in = CreatePipe, - std_out = CreatePipe - } - (ex, output) <- withCreateProcess_ "readCreateProcess" cp_opts $ - \(Just inh) (Just outh) _ ph -> do - - -- fork off a thread to start consuming the output - output <- hGetContents outh - withForkWait (C.evaluate $ rnf output) $ \waitOut -> do - - -- now write any input - unless (null input) $ - ignoreSigPipe $ hPutStr inh input - -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE - ignoreSigPipe $ hClose inh - - -- wait on the output - waitOut - hClose outh - - -- wait on the process - ex <- waitForProcess ph - return (ex, output) - - case ex of - ExitSuccess -> return output - ExitFailure r -> processFailedException "readCreateProcess" cmd args r - where - cmd = case cp of - CreateProcess { cmdspec = ShellCommand sc } -> sc - CreateProcess { cmdspec = RawCommand fp _ } -> fp - args = case cp of - CreateProcess { cmdspec = ShellCommand _ } -> [] - CreateProcess { cmdspec = RawCommand _ args' } -> args' - - --- | @readProcessWithExitCode@ is like @readProcess@ but with two differences: --- --- * it returns the 'ExitCode' of the process, and does not throw any --- exception if the code is not 'ExitSuccess'. --- --- * it reads and returns the output from process' standard error handle, --- rather than the process inheriting the standard error handle. --- --- On Unix systems, see 'waitForProcess' for the meaning of exit codes --- when the process died as the result of a signal. --- -readProcessWithExitCode - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args = - readCreateProcessWithExitCode $ proc cmd args - --- | @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 -readCreateProcessWithExitCode - :: CreateProcess - -> String -- ^ standard input - -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr -readCreateProcessWithExitCode cp input = do - let cp_opts = cp { - std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $ - \(Just inh) (Just outh) (Just errh) ph -> do - - out <- hGetContents outh - err <- hGetContents errh - - -- fork off threads to start consuming stdout & stderr - withForkWait (C.evaluate $ rnf out) $ \waitOut -> - withForkWait (C.evaluate $ rnf err) $ \waitErr -> do - - -- now write any input - unless (null input) $ - ignoreSigPipe $ hPutStr 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, out, err) - --- | 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) `C.onException` killThread tid - -ignoreSigPipe :: IO () -> IO () -ignoreSigPipe = C.handle $ \e -> case e of - IOError { ioe_type = ResourceVanished - , ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e - --- ---------------------------------------------------------------------------- --- showCommandForUser - --- | Given a program @/p/@ and arguments @/args/@, --- @showCommandForUser /p/ /args/@ returns a string suitable for pasting --- into @\/bin\/sh@ (on Unix systems) or @CMD.EXE@ (on Windows). -showCommandForUser :: FilePath -> [String] -> String -showCommandForUser cmd args = unwords (map translate (cmd : args)) - - --- ---------------------------------------------------------------------------- --- waitForProcess - -{- | Waits for the specified process to terminate, and returns its exit code. - -GHC Note: in order to call @waitForProcess@ without blocking all the -other threads in the system, you must compile the program with -@-threaded@. - -(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ -indicates that the child was terminated by signal @/signum/@. -The signal numbers are platform-specific, so to test for a specific signal use -the constants provided by "System.Posix.Signals" in the @unix@ package. -Note: core dumps are not reported, use "System.Posix.Process" if you need this -detail. - --} -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 - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) - 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 - -{- | -This is a non-blocking version of 'waitForProcess'. If the process is -still running, 'Nothing' is returned. If the process has exited, then -@'Just' e@ is returned where @e@ is the exit code of the process. - -On Unix systems, see 'waitForProcess' for the meaning of exit codes -when the process died as the result of a signal. --} - -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 - --- | Attempts to terminate the specified process. This function should --- not be used under normal circumstances - no guarantees are given regarding --- how cleanly the process is terminated. To check whether the process --- has indeed terminated, use 'getProcessExitCode'. --- --- On Unix systems, 'terminateProcess' sends the process the SIGTERM signal. --- On Windows systems, the Win32 @TerminateProcess@ function is called, passing --- an exit code of 1. --- --- Note: on Windows, if the process was a shell command created by --- 'createProcess' with 'shell', or created by 'runCommand' or --- 'runInteractiveCommand', then 'terminateProcess' will only --- terminate the shell, not the command itself. On Unix systems, both --- processes are in a process group and will be terminated together. - -terminateProcess :: ProcessHandle -> IO () -terminateProcess ph = do - withProcessHandle ph $ \p_ -> - case p_ of - ClosedHandle _ -> return () - OpenHandle h -> do - throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h - return () - -- does not close the handle, we might want to try terminating it - -- again, or get its exit code. - - --- ---------------------------------------------------------------------------- --- Interface to C bits - -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" -- NB. safe - can block - c_waitForProcess - :: PHANDLE - -> Ptr CInt - -> IO CInt - - --- ---------------------------------------------------------------------------- --- Old deprecated variants --- ---------------------------------------------------------------------------- - --- TODO: We're not going to mark these functions as DEPRECATED immediately in --- process-1.2.0.0. That's because some of their replacements have not been --- around for all that long. But they should eventually be marked with a --- suitable DEPRECATED pragma after a release or two. - - --- ---------------------------------------------------------------------------- --- runCommand - ---TODO: in a later release {-# DEPRECATED runCommand "Use 'spawnCommand' instead" #-} - -{- | Runs a command using the shell. - -} -runCommand - :: String - -> IO ProcessHandle - -runCommand string = do - (_,_,_,ph) <- createProcess_ "runCommand" (shell string) - return ph - - --- ---------------------------------------------------------------------------- --- runProcess - ---TODO: in a later release {-# DEPRECATED runProcess "Use 'spawnProcess' or 'createProcess' instead" #-} - -{- | Runs a raw command, optionally specifying 'Handle's from which to - take the @stdin@, @stdout@ and @stderr@ channels for the new - process (otherwise these handles are inherited from the current - process). - - Any 'Handle's passed to 'runProcess' are placed immediately in the - closed state. - - Note: consider using the more general 'createProcess' instead of - 'runProcess'. --} -runProcess - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> Maybe Handle -- ^ Handle to use for @stdin@ (Nothing => use existing @stdin@) - -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) - -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) - -> 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 - ---TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} - -{- | Runs a command using the shell, and returns 'Handle's that may - be used to communicate with the process via its @stdin@, @stdout@, - and @stderr@ respectively. The 'Handle's are initially in binary - mode; if you need them to be in text mode then use 'hSetBinaryMode'. --} -runInteractiveCommand - :: String - -> IO (Handle,Handle,Handle,ProcessHandle) - -runInteractiveCommand string = - runInteractiveProcess1 "runInteractiveCommand" (shell string) - - --- ---------------------------------------------------------------------------- --- runInteractiveProcess - ---TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} - -{- | Runs a raw command, and returns 'Handle's that may be used to communicate - with the process via its @stdin@, @stdout@ and @stderr@ respectively. - - For example, to start a process and feed a string to its stdin: - -> (inp,out,err,pid) <- runInteractiveProcess "..." -> forkIO (hPutStr inp str) - - The 'Handle's are initially in binary mode; if you need them to be - in text mode then use 'hSetBinaryMode'. --} -runInteractiveProcess - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> 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) - - --- --------------------------------------------------------------------------- --- system & rawSystem - ---TODO: in a later release {-# DEPRECATED system "Use 'callCommand' (or 'spawnCommand' and 'waitForProcess') instead" #-} - -{-| -Computation @system cmd@ returns the exit code produced when the -operating system runs the shell command @cmd@. - -This computation may fail with one of the following -'System.IO.Error.IOErrorType' exceptions: - -[@PermissionDenied@] -The process has insufficient privileges to perform the operation. - -[@ResourceExhausted@] -Insufficient resources are available to perform the operation. - -[@UnsupportedOperation@] -The implementation does not support system calls. - -On Windows, 'system' passes the command to the Windows command -interpreter (@CMD.EXE@ or @COMMAND.COM@), hence Unixy shell tricks -will not work. - -On Unix systems, see 'waitForProcess' for the meaning of exit codes -when the process died as the result of a signal. --} -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 - - ---TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} - -{-| -The computation @'rawSystem' /cmd/ /args/@ runs the operating system command -@/cmd/@ in such a way that it receives as arguments the @/args/@ strings -exactly as given, with no funny escaping or shell meta-syntax expansion. -It will therefore behave more portably between operating systems than 'system'. - -The return codes and possible failures are the same as for 'system'. --} -rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = do - (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } - waitForProcess p diff --git a/System/Process/Common.hs b/System/Process/Common.hs --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -57,6 +57,7 @@ -- will never actually be used, as the setuid/setgid system calls are not -- applicable on Windows. No value of this type will ever exist. newtype CGid = CGid Word32 + deriving (Show, Eq) type GroupID = CGid type UserID = CGid #else @@ -64,7 +65,7 @@ #endif data CreateProcess = CreateProcess{ - cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command + cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command. Relative paths are resolved with respect to 'cwd' if given, and otherwise the current working directory. cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process) std_in :: StdStream, -- ^ How to determine stdin @@ -98,7 +99,7 @@ -- Default: @Nothing@ -- -- @since 1.4.0.0 - } + } deriving (Show, Eq) data CmdSpec = ShellCommand String @@ -125,6 +126,7 @@ -- see the -- -- for the Windows @SearchPath@ API. + deriving (Show, Eq) -- | construct a `ShellCommand` from a string literal @@ -141,6 +143,7 @@ -- and newline translation mode (just -- like @Handle@s created by @openFile@). | NoStream -- ^ No stream handle will be passed + deriving (Eq, Show) -- ---------------------------------------------------------------------------- -- ProcessHandle type diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -50,7 +50,7 @@ import System.Process.Common -#if WINDOWS +#ifdef WINDOWS import System.Process.Windows #else import System.Process.Posix diff --git a/cbits/runProcess.c b/cbits/runProcess.c --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -84,6 +84,10 @@ if (fdStdOut == -1) { r = pipe(fdStdOutput); if (r == -1) { + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } *failed_doing = "runInteractiveProcess: pipe"; return -1; } @@ -92,6 +96,14 @@ r = pipe(fdStdError); if (r == -1) { *failed_doing = "runInteractiveProcess: pipe"; + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } + if (fdStdOut == -1) { + close(fdStdOutput[0]); + close(fdStdOutput[1]); + } return -1; } } @@ -327,6 +339,19 @@ // We forked the child, but the child had a problem and stopped so it's // our responsibility to reap here as nobody else can. waitpid(pid, NULL, 0); + + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } + if (fdStdOut == -1) { + close(fdStdOutput[0]); + close(fdStdOutput[1]); + } + if (fdStdErr == -1) { + close(fdStdError[0]); + close(fdStdError[1]); + } pid = -1; } diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.4.3.0 *December 2016* + +* New exposed `withCreateProcess` +* Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` + ## 1.4.2.0 *January 2016* * Added `createPipeFD` [#52](https://github.com/haskell/process/pull/52) diff --git a/exes/echo.bat b/exes/echo.bat new file mode 100644 --- /dev/null +++ b/exes/echo.bat @@ -0,0 +1,1 @@ +echo parent diff --git a/exes/subdir/echo.bat b/exes/subdir/echo.bat new file mode 100644 --- /dev/null +++ b/exes/subdir/echo.bat @@ -0,0 +1,1 @@ +echo child diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.4.2.0 +version: 1.4.3.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -19,6 +19,8 @@ configure.ac include/HsProcessConfig.h.in process.buildinfo + exes/echo.bat + exes/subdir/echo.bat extra-tmp-files: autom4te.cache @@ -66,8 +68,8 @@ ghc-options: -Wall - build-depends: base >= 4.4 && < 4.10, - directory >= 1.1 && < 1.3, + build-depends: base >= 4.4 && < 4.11, + directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5, deepseq >= 1.1 && < 1.5 @@ -77,4 +79,6 @@ main-is: main.hs type: exitcode-stdio-1.0 build-depends: base + , bytestring + , directory , process diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,7 +1,14 @@ import Control.Exception +import Control.Monad (unless) import System.Exit import System.IO.Error +import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Process +import Data.List (isInfixOf) +import System.IO (hClose, openBinaryTempFile) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import System.Directory (getTemporaryDirectory, removeFile) main :: IO () main = do @@ -27,4 +34,44 @@ test "create_new_console" $ \cp -> cp { create_new_console = True } test "new_session" $ \cp -> cp { new_session = True } + putStrLn "Testing subdirectories" + + withCurrentDirectory "exes" $ do + res1 <- readCreateProcess (proc "./echo.bat" []) "" + unless ("parent" `isInfixOf` res1 && not ("child" `isInfixOf` res1)) $ error $ + "echo.bat with cwd failed: " ++ show res1 + + res2 <- readCreateProcess (proc "./echo.bat" []) { cwd = Just "subdir" } "" + unless ("child" `isInfixOf` res2 && not ("parent" `isInfixOf` res2)) $ error $ + "echo.bat with cwd failed: " ++ show res2 + + putStrLn "Binary handles" + tmpDir <- getTemporaryDirectory + bracket + (openBinaryTempFile tmpDir "process-binary-test.bin") + (\(fp, h) -> hClose h `finally` removeFile fp) + $ \(fp, h) -> do + let bs = S8.pack "hello\nthere\r\nworld\0" + S.hPut h bs + hClose h + + (Nothing, Just out, Nothing, ph) <- createProcess (proc "cat" [fp]) + { std_out = CreatePipe + } + res' <- S.hGetContents out + hClose out + ec <- waitForProcess ph + unless (ec == ExitSuccess) + $ error $ "Unexpected exit code " ++ show ec + unless (bs == res') + $ error $ "Unexpected result: " ++ show res' + putStrLn "Tests passed successfully" + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory new inner = do + orig <- getCurrentDirectory + bracket_ + (setCurrentDirectory new) + (setCurrentDirectory orig) + inner