diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -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 diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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 diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 --- /dev/null +++ b/aclocal.m4 @@ -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 + diff --git a/cbits/runProcess.c b/cbits/runProcess.c --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -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; } diff --git a/include/runProcess.h b/include/runProcess.h --- a/include/runProcess.h +++ b/include/runProcess.h @@ -13,6 +13,7 @@ #undef PACKAGE_VERSION #if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#define UNICODE #include #include #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 diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -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