process 1.0.1.1 → 1.0.1.2
raw patch · 6 files changed
+251/−91 lines, 6 filesdep ~basenew-uploader
Dependency ranges changed: base
Files
- System/Process.hs +19/−17
- System/Process/Internals.hs +87/−13
- aclocal.m4 +50/−0
- cbits/runProcess.c +82/−55
- include/runProcess.h +5/−3
- process.cabal +8/−3
System/Process.hs view
@@ -75,9 +75,12 @@ import System.Exit ( ExitCode(..) ) #ifdef __GLASGOW_HASKELL__-import GHC.IOBase ( ioException, IOException(..), IOErrorType(..) )+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Exception ( ioException, IOErrorType(..) )+#else+import GHC.IOBase ( ioException, IOErrorType(..) )+#endif #if !defined(mingw32_HOST_OS)-import System.Process.Internals import System.Posix.Signals #endif #endif@@ -221,7 +224,7 @@ :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess cp = do- r <- runGenProcess_ "runGenProcess" cp Nothing Nothing+ r <- runGenProcess_ "createProcess" cp Nothing Nothing maybeCloseStd (std_in cp) maybeCloseStd (std_out cp) maybeCloseStd (std_err cp)@@ -355,7 +358,7 @@ -- fork off a thread to start consuming the output output <- hGetContents outh outMVar <- newEmptyMVar- forkIO $ C.evaluate (length output) >> putMVar outMVar ()+ _ <- forkIO $ C.evaluate (length output) >> putMVar outMVar () -- now write and flush any input when (not (null input)) $ do hPutStr inh input; hFlush inh@@ -403,11 +406,11 @@ -- fork off a thread to start consuming stdout out <- hGetContents outh- forkIO $ C.evaluate (length out) >> putMVar outMVar ()+ _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar () -- fork off a thread to start consuming stderr err <- hGetContents errh- forkIO $ C.evaluate (length err) >> putMVar outMVar ()+ _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () -- now write and flush any input when (not (null input)) $ do hPutStr inh input; hFlush inh@@ -448,16 +451,17 @@ -} #ifdef __GLASGOW_HASKELL__ system :: String -> IO ExitCode-system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)-system str = syncProcess (shell str)+system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")+system str = syncProcess "system" (shell str) -syncProcess :: CreateProcess -> IO ExitCode-syncProcess c = do+syncProcess :: String -> CreateProcess -> IO ExitCode #if mingw32_HOST_OS+syncProcess _fun c = do (_,_,_,p) <- createProcess c waitForProcess p #else+syncProcess fun c = do -- The POSIX version of system needs to do some manipulation of signal -- handlers. Since we're going to be synchronously waiting for the child, -- we want to ignore ^C in the parent, but handle it the default way@@ -466,11 +470,11 @@ -- its own handler and we don't want to use that). old_int <- installHandler sigINT Ignore Nothing old_quit <- installHandler sigQUIT Ignore Nothing- (_,_,_,p) <- runGenProcess_ "runCommand" c+ (_,_,_,p) <- runGenProcess_ fun c (Just defaultSignal) (Just defaultSignal) r <- waitForProcess p- installHandler sigINT old_int Nothing- installHandler sigQUIT old_quit Nothing+ _ <- installHandler sigINT old_int Nothing+ _ <- installHandler sigQUIT old_quit Nothing return r #endif /* mingw32_HOST_OS */ #endif /* __GLASGOW_HASKELL__ */@@ -485,7 +489,7 @@ -} rawSystem :: String -> [String] -> IO ExitCode #ifdef __GLASGOW_HASKELL__-rawSystem cmd args = syncProcess (proc cmd args)+rawSystem cmd args = syncProcess "rawSystem" (proc cmd args) #elif !mingw32_HOST_OS -- crude fallback implementation: could do much better than this under Unix@@ -520,7 +524,7 @@ -- how cleanly the process is terminated. To check whether the process -- has indeed terminated, use 'getProcessExitCode'. ----- On Unix systems, 'terminateProcess' sends the process the SIGKILL signal.+-- 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. --@@ -548,8 +552,6 @@ 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.-Subsequent calls to @getProcessExitStatus@ always return @'Just'-'ExitSuccess'@, regardless of what the original exit code was. -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) getProcessExitCode ph = do
System/Process/Internals.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -w #-} -- XXX We get some warnings on Windows@@ -63,13 +63,36 @@ import Foreign # ifdef __GLASGOW_HASKELL__+ import System.Posix.Internals+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Exception+import GHC.IO.Encoding+import qualified GHC.IO.FD as FD+import GHC.IO.Device+import GHC.IO.Handle+import GHC.IO.Handle.FD+import GHC.IO.Handle.Internals+import GHC.IO.Handle.Types+import System.IO.Error+import Data.Typeable+#if defined(mingw32_HOST_OS)+import GHC.IO.IOMode+#endif+#else import GHC.IOBase ( haFD, FD, IOException(..) ) import GHC.Handle+#endif+ # elif __HUGS__+ import Hugs.Exception ( IOException(..) )+ # endif +#ifdef base4+import System.IO.Error ( ioeSetFileName )+#endif #if defined(mingw32_HOST_OS) import Control.Monad ( when ) import System.Directory ( doesFileExist )@@ -162,7 +185,7 @@ std_in :: StdStream, -- ^ How to determine stdin std_out :: StdStream, -- ^ How to determine stdout std_err :: StdStream, -- ^ How to determine stderr- close_fds :: Bool -- ^ Close all file descriptors except stdin, stdout and stderr in the new process+ close_fds :: Bool -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit) } data CmdSpec @@ -222,7 +245,12 @@ Nothing -> (0, 0) Just hand -> (1, hand) - proc_handle <- throwErrnoIfMinus1 fun $+ -- runInteractiveProcess() blocks signals around the fork().+ -- Since blocking/unblocking of signals is a global state+ -- operation, we better ensure mutual exclusion of calls to+ -- runInteractiveProcess().+ proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->+ throwErrnoIfMinus1 fun $ c_runInteractiveProcess pargs pWorkDir pEnv fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError@@ -236,6 +264,10 @@ ph <- mkProcessHandle proc_handle return (hndStdInput, hndStdOutput, hndStdError, ph) +{-# NOINLINE runInteractiveProcess_lock #-}+runInteractiveProcess_lock :: MVar ()+runInteractiveProcess_lock = unsafePerformIO $ newMVar ()+ foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: Ptr CString@@ -270,7 +302,7 @@ std_in = mb_stdin, std_out = mb_stdout, std_err = mb_stderr,- close_fds = _ignored_mb_close_fds }+ close_fds = mb_close_fds } _ignored_mb_sigint _ignored_mb_sigquit = do (cmd, cmdline) <- commandToProcess cmdsp@@ -279,17 +311,29 @@ alloca $ \ pfdStdOutput -> alloca $ \ pfdStdError -> maybeWith withCEnvironment mb_env $ \pEnv ->- maybeWith withCString mb_cwd $ \pWorkDir -> do- withCString cmdline $ \pcmdline -> do+ maybeWith withCWString mb_cwd $ \pWorkDir -> do+ withCWString cmdline $ \pcmdline -> do fdin <- mbFd fun fd_stdin mb_stdin fdout <- mbFd fun fd_stdout mb_stdout fderr <- mbFd fun fd_stderr mb_stderr - proc_handle <- throwErrnoIfMinus1 fun $+ -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,+ -- because otherwise there is a race condition whereby one thread+ -- has created some pipes, and another thread spawns a process which+ -- accidentally inherits some of the pipe handles that the first+ -- thread has created.+ -- + -- An MVar in Haskell is the best way to do this, because there+ -- is no way to do one-time thread-safe initialisation of a mutex+ -- the C code. Also the MVar will be cheaper when not running+ -- the threaded RTS.+ proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->+ throwErrnoIfMinus1 fun $ c_runInteractiveProcess pcmdline pWorkDir pEnv fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError+ (if mb_close_fds then 1 else 0) hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode@@ -298,11 +342,14 @@ ph <- mkProcessHandle proc_handle return (hndStdInput, hndStdOutput, hndStdError, ph) +{-# NOINLINE runInteractiveProcess_lock #-}+runInteractiveProcess_lock :: MVar ()+runInteractiveProcess_lock = unsafePerformIO $ newMVar () foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess- :: CString- -> CString+ :: CWString+ -> CWString -> Ptr () -> FD -> FD@@ -310,6 +357,7 @@ -> Ptr FD -> Ptr FD -> Ptr FD+ -> CInt -- close_fds -> IO PHANDLE -- ------------------------------------------------------------------------@@ -390,9 +438,24 @@ fd_stderr = 2 mbFd :: String -> FD -> StdStream -> IO FD-mbFd _fun std Inherit = return std-mbFd fun _std (UseHandle hdl) = withHandle_ fun hdl $ return . haFD mbFd _ _std CreatePipe = return (-1)+mbFd _fun std Inherit = return std+mbFd fun _std (UseHandle hdl) = +#if __GLASGOW_HASKELL__ < 611+ withHandle_ fun hdl $ return . haFD+#else+ withHandle fun hdl $ \h@Handle__{haDevice=dev,..} ->+ case cast dev of+ Just fd -> do+ -- clear the O_NONBLOCK flag on this FD, if it is set, since+ -- we're exposing it externally (see #3316)+ fd <- FD.setNonBlockingMode fd False+ return (Handle__{haDevice=fd,..}, FD.fdFD fd)+ Nothing ->+ ioError (mkIOError illegalOperationErrorType+ "createProcess" (Just hdl) Nothing+ `ioeSetErrorString` "handle is not a file descriptor")+#endif mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle) mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode)@@ -401,9 +464,20 @@ pfdToHandle :: Ptr FD -> IOMode -> IO Handle pfdToHandle pfd mode = do fd <- peek pfd+ let filepath = "fd:" ++ show fd+#if __GLASGOW_HASKELL__ >= 611+ (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode + (Just (Stream,0,0)) -- avoid calling fstat()+ False {-is_socket-}+ False {-non-blocking-}+ fD <- FD.setNonBlockingMode fD True -- see #3316+ mkHandleFromFD fD fd_type filepath mode False{-is_socket-}+ (Just localeEncoding)+#else fdToHandle' fd (Just Stream) False{-Windows: not a socket, Unix: don't set non-blocking-}- ("fd:" ++ show fd) mode True{-binary-}+ filepath mode True{-binary-}+#endif #ifndef __HUGS__ -- ----------------------------------------------------------------------------@@ -501,7 +575,7 @@ withFilePathException fpath act = handle mapEx act where #ifdef base4- mapEx (IOError h iot fun str _) = ioError (IOError h iot fun str (Just fpath))+ mapEx ex = ioError (ioeSetFileName ex fpath) #else mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath)) #endif
+ aclocal.m4 view
@@ -0,0 +1,50 @@+# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS)+# --------------------------------------------------------+# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for+# compilation. Execute IF-FAILS when unable to determine the value. Works for+# cross-compilation, too.+#+# Implementation note: We are lazy and use an internal autoconf macro, but it+# is supported in autoconf versions 2.50 up to the actual 2.57, so there is+# little risk.+AC_DEFUN([FP_COMPUTE_INT],+[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl+])# FP_COMPUTE_INT+++# FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])+# -------------------------------------------------------------------------------+# Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using+# INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL.+AC_DEFUN([FP_CHECK_CONST],+[AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl+AC_CACHE_CHECK([value of $1], fp_Cache,+[FP_COMPUTE_INT([$1], fp_check_const_result, [AC_INCLUDES_DEFAULT([$2])],+ [fp_check_const_result=m4_default([$3], ['-1'])])+AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl+AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl+AS_VAR_POPDEF([fp_Cache])[]dnl+])# FP_CHECK_CONST+++# FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...)+# ---------------------------------------+# autoheader helper for FP_CHECK_CONSTS+m4_define([FP_CHECK_CONSTS_TEMPLATE],+[AC_FOREACH([fp_Const], [$1],+ [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),+ [The value of ]fp_Const[.])])[]dnl+])# FP_CHECK_CONSTS_TEMPLATE+++# FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])+# -----------------------------------------------------------------------------------+# List version of FP_CHECK_CONST+AC_DEFUN([FP_CHECK_CONSTS],+[FP_CHECK_CONSTS_TEMPLATE([$1])dnl+for fp_const_name in $1+do+FP_CHECK_CONST([$fp_const_name], [$2], [$3])+done+])# FP_CHECK_CONSTS+
cbits/runProcess.c view
@@ -4,6 +4,10 @@ Support for System.Process ------------------------------------------------------------------------- */ +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+#define UNICODE+#endif+ /* XXX This is a nasty hack; should put everything necessary in this package */ #include "HsBase.h" #include "Rts.h"@@ -30,6 +34,10 @@ static long max_fd = 0; +// Rts internal API, not exposed in a public header file:+extern void blockUserSignals(void);+extern void unblockUserSignals(void);+ ProcHandle runInteractiveProcess (char *const args[], char *workingDirectory, char **environment,@@ -41,21 +49,43 @@ { int pid; int fdStdInput[2], fdStdOutput[2], fdStdError[2];+ int r; struct sigaction dfl; if (fdStdIn == -1) {- pipe(fdStdInput);+ r = pipe(fdStdInput);+ if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe");+ return -1;+ }+ } if (fdStdOut == -1) {- pipe(fdStdOutput);+ r = pipe(fdStdOutput);+ if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe");+ return -1;+ } } if (fdStdErr == -1) {- pipe(fdStdError);+ r = pipe(fdStdError);+ if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe");+ return -1;+ } } + // Block signals with Haskell handlers. The danger here is that+ // with the threaded RTS, a signal arrives in the child process,+ // the RTS writes the signal information into the pipe (which is+ // shared between parent and child), and the parent behaves as if+ // the signal had been raised.+ blockUserSignals();+ switch(pid = fork()) { case -1:+ unblockUserSignals(); if (fdStdIn == -1) { close(fdStdInput[0]); close(fdStdInput[1]);@@ -72,8 +102,12 @@ case 0: {+ // WARNING! we are now in the child of vfork(), so any memory+ // we modify below will also be seen in the parent process.+ disableItimers();- + unblockUserSignals();+ if (workingDirectory) { if (chdir (workingDirectory) < 0) { // See #1593. The convention for the exit code when@@ -171,6 +205,7 @@ } break; }+ unblockUserSignals(); return pid; }@@ -264,16 +299,9 @@ { HANDLE hTemporaryIn = NULL; HANDLE hTemporaryOut = NULL;- BOOL status;- SECURITY_ATTRIBUTES sec_attrs; - /* Create inheritable security attributes */- sec_attrs.nLength = sizeof(SECURITY_ATTRIBUTES);- sec_attrs.lpSecurityDescriptor = NULL;- sec_attrs.bInheritHandle = TRUE;- /* Create the anon pipe with both ends inheritable */- if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, &sec_attrs, 0))+ if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0)) { maperrno(); *pHandleIn = NULL;@@ -281,55 +309,46 @@ return FALSE; } - if (isInheritableIn)- *pHandleIn = hTemporaryIn;- else- {- /* Make the read end non-inheritable */- status = DuplicateHandle(GetCurrentProcess(), hTemporaryIn,- GetCurrentProcess(), pHandleIn,- 0,- FALSE, /* non-inheritable */- DUPLICATE_SAME_ACCESS);- CloseHandle(hTemporaryIn);- if (!status)- {- maperrno();- *pHandleIn = NULL;- *pHandleOut = NULL;- CloseHandle(hTemporaryOut);- return FALSE;- }- }-- if (isInheritableOut)- *pHandleOut = hTemporaryOut;- else- {- /* Make the write end non-inheritable */- status = DuplicateHandle(GetCurrentProcess(), hTemporaryOut,- GetCurrentProcess(), pHandleOut,- 0,- FALSE, /* non-inheritable */- DUPLICATE_SAME_ACCESS);- CloseHandle(hTemporaryOut);- if (!status)- {- maperrno();- *pHandleIn = NULL;- *pHandleOut = NULL;- CloseHandle(*pHandleIn);- return FALSE;- }+ if (isInheritableIn) {+ // SetHandleInformation requires at least Win2k+ if (!SetHandleInformation(hTemporaryIn,+ HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT))+ {+ maperrno();+ *pHandleIn = NULL;+ *pHandleOut = NULL;+ CloseHandle(hTemporaryIn);+ CloseHandle(hTemporaryOut);+ return FALSE;+ } }+ *pHandleIn = hTemporaryIn; + if (isInheritableOut) {+ if (!SetHandleInformation(hTemporaryOut,+ HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT))+ {+ maperrno();+ *pHandleIn = NULL;+ *pHandleOut = NULL;+ CloseHandle(hTemporaryIn);+ CloseHandle(hTemporaryOut);+ return FALSE;+ }+ }+ *pHandleOut = hTemporaryOut;+ return TRUE; } ProcHandle-runInteractiveProcess (char *cmd, char *workingDirectory, void *environment,+runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, + void *environment, int fdStdIn, int fdStdOut, int fdStdErr,- int *pfdStdInput, int *pfdStdOutput, int *pfdStdError)+ int *pfdStdInput, int *pfdStdOutput, int *pfdStdError,+ int close_fds) { STARTUPINFO sInfo; PROCESS_INFORMATION pInfo;@@ -341,6 +360,7 @@ HANDLE hStdErrorWrite = INVALID_HANDLE_VALUE; DWORD flags; BOOL status;+ BOOL inherit; ZeroMemory(&sInfo, sizeof(sInfo)); sInfo.cb = sizeof(sInfo);@@ -413,7 +433,14 @@ else flags = 0; - if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, flags, environment, workingDirectory, &sInfo, &pInfo))+ // See #3231+ if (close_fds && fdStdIn == 0 && fdStdOut == 1 && fdStdErr == 2) {+ inherit = FALSE;+ } else {+ inherit = TRUE;+ }++ if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, flags, environment, workingDirectory, &sInfo, &pInfo)) { goto cleanup_err; }
include/runProcess.h view
@@ -13,6 +13,7 @@ #undef PACKAGE_VERSION #if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+#define UNICODE #include <windows.h> #include <stdlib.h> #endif@@ -58,13 +59,14 @@ #else -extern ProcHandle runInteractiveProcess( char *cmd, - char *workingDirectory, +extern ProcHandle runInteractiveProcess( wchar_t *cmd,+ wchar_t *workingDirectory, void *environment, int fdStdIn, int fdStdOut, int fdStdErr, int *pfdStdInput, int *pfdStdOutput,- int *pfdStdError);+ int *pfdStdError,+ int close_fds); #endif
process.cabal view
@@ -1,20 +1,25 @@ name: process-version: 1.0.1.1+version: 1.0.1.2 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org+bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/process synopsis: Process libraries category: System description: This package contains libraries for dealing with system processes. extra-source-files:- configure.ac configure+ aclocal.m4 configure.ac configure include/HsProcessConfig.h.in extra-tmp-files: config.log config.status autom4te.cache include/HsProcessConfig.h build-type: Configure-cabal-version: >=1.2+cabal-version: >=1.6++source-repository head+ type: darcs+ location: http://darcs.haskell.org/packages/process/ flag base4