process 1.6.17.0 → 1.6.18.0
raw patch · 15 files changed
+1191/−75 lines, 15 filesdep ~Win32dep ~basedep ~deepseqnew-uploader
Dependency ranges changed: Win32, base, deepseq, filepath
Files
- System/Process.hs +46/−5
- System/Process/Common.hs +18/−10
- System/Process/Internals.hs +6/−3
- System/Process/JavaScript.hs +308/−0
- System/Process/Windows.hsc +81/−15
- cbits/posix/find_executable.c +3/−1
- cbits/posix/fork_exec.c +58/−28
- cbits/win32/runProcess.c +23/−2
- changelog.md +8/−0
- configure +7/−0
- configure.ac +6/−1
- include/HsProcessConfig.h.in +3/−0
- jsbits/process.js +581/−0
- process.cabal +15/−10
- test/main.hs +28/−0
System/Process.hs view
@@ -8,6 +8,10 @@ #include <ghcplatform.h> +#if defined(javascript_HOST_ARCH)+{-# LANGUAGE JavaScriptFFI #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : System.Process@@ -85,7 +89,11 @@ import Control.Concurrent import Control.DeepSeq (rnf)-import Control.Exception (SomeException, mask, allowInterrupt, bracket, try, throwIO)+import Control.Exception (SomeException, mask+#if !defined(javascript_HOST_ARCH)+ , allowInterrupt+#endif+ , bracket, try, throwIO) import qualified Control.Exception as C import Control.Monad import Data.Maybe@@ -95,7 +103,9 @@ import System.IO import System.IO.Error (mkIOError, ioeSetErrorString) -#if defined(WINDOWS)+#if defined(javascript_HOST_ARCH)+import System.Process.JavaScript(getProcessId, getCurrentProcessId)+#elif defined(WINDOWS) import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId) #else import System.Posix.Process (getProcessID)@@ -114,7 +124,9 @@ -- This is always an integral type. Width and signedness are platform specific. -- -- @since 1.6.3.0-#if defined(WINDOWS)+#if defined(javascript_HOST_ARCH)+type Pid = Int+#elif defined(WINDOWS) type Pid = ProcessId #else type Pid = CPid@@ -651,10 +663,14 @@ getPid (ProcessHandle mh _ _) = do p_ <- readMVar mh case p_ of-#ifdef WINDOWS+#if defined(javascript_HOST_ARCH) OpenHandle h -> do pid <- getProcessId h return $ Just pid+#elif defined(WINDOWS)+ OpenHandle h -> do+ pid <- getProcessId h+ return $ Just pid #else OpenHandle pid -> return $ Just pid #endif@@ -672,8 +688,10 @@ -- @since 1.6.12.0 getCurrentPid :: IO Pid getCurrentPid =-#ifdef WINDOWS+#if defined(javascript_HOST_ARCH) getCurrentProcessId+#elif defined(WINDOWS)+ getCurrentProcessId #else getProcessID #endif@@ -753,7 +771,11 @@ waitForProcess' :: PHANDLE -> IO ExitCode waitForProcess' h = alloca $ \pret -> do+#if defined(javascript_HOST_ARCH)+ throwErrnoIfMinus1Retry_ "waitForProcess" (C.interruptible $ c_waitForProcess h pret)+#else throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)+#endif mkExitCode <$> peek pret mkExitCode :: CInt -> ExitCode@@ -874,6 +896,25 @@ c_waitForProcess :: PHANDLE -> Ptr CInt -> IO CInt c_waitForProcess _ _ = ioError (ioeSetLocation unsupportedOperation "waitForProcess")++#elif defined(javascript_HOST_ARCH)++foreign import javascript unsafe "h$process_terminateProcess"+ c_terminateProcess+ :: PHANDLE+ -> IO Int++foreign import javascript unsafe "h$process_getProcessExitCode"+ c_getProcessExitCode+ :: PHANDLE+ -> Ptr Int+ -> IO Int++foreign import javascript interruptible "h$process_waitForProcess"+ c_waitForProcess+ :: PHANDLE+ -> Ptr CInt+ -> IO CInt #else
System/Process/Common.hs view
@@ -57,6 +57,10 @@ import Data.Typeable import System.IO (IOMode) +#if defined(javascript_HOST_ARCH)+import GHC.JS.Prim (JSVal)+#endif+ -- We do a minimal amount of CPP here to provide uniform data types across -- Windows and POSIX. #ifdef WINDOWS@@ -69,7 +73,9 @@ import System.Posix.Types #endif -#ifdef WINDOWS+#if defined(javascript_HOST_ARCH)+type PHANDLE = JSVal+#elif defined(WINDOWS) -- Define some missing types for Windows compatibility. Note that these values -- will never actually be used, as the setuid/setgid system calls are not -- applicable on Windows. No value of this type will ever exist.@@ -80,7 +86,6 @@ #else type PHANDLE = CPid #endif- data CreateProcess = CreateProcess{ cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command. If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory. If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability. cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process@@ -88,12 +93,10 @@ 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 (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files.- create_group :: Bool, -- ^ Create a new process group+ 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). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. XXX verify what happens with fds in nodejs child processes+ create_group :: Bool, -- ^ Create a new process group. On JavaScript this also creates a new session. delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details). --- -- On Windows this has no effect.- -- -- @since 1.2.0.0 detach_console :: Bool, -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms. --@@ -103,15 +106,15 @@ -- Default: @False@ -- -- @since 1.3.0.0- new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms.+ new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; starts process in a new session on JavaScript; does nothing on other platforms. -- -- @since 1.3.0.0- child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; does nothing on other platforms.+ child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; works for JavaScript when system running nodejs is posix. does nothing on other platforms. -- -- Default: @Nothing@ -- -- @since 1.4.0.0- child_user :: Maybe UserID, -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.+ child_user :: Maybe UserID, -- ^ Use posix setuid to set child process's user id; works for JavaScript when system running nodejs is posix. does nothing on other platforms. -- -- Default: @Nothing@ --@@ -245,12 +248,17 @@ mbFd _fun std Inherit = return std mbFd _fn _std NoStream = return (-2) mbFd fun _std (UseHandle hdl) =- withHandle fun hdl $ \Handle__{haDevice=dev,..} ->+ withHandle fun hdl $ \Handle__{haDevice=dev,..} -> do case cast dev of Just fd -> do+#if !defined(javascript_HOST_ARCH) -- 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+#else+ -- on the JavaScript platform we cannot change the FD flags+ fd' <- pure fd+#endif return (Handle__{haDevice=fd',..}, FD.fdFD fd') Nothing -> ioError (mkIOError illegalOperationErrorType
System/Process/Internals.hs view
@@ -45,10 +45,12 @@ waitForJobCompletion, timeout_Infinite, #else+#if !defined(javascript_HOST_ARCH) pPrPr_disableITimers, c_execvpe,- ignoreSignal, defaultSignal, runInteractiveProcess_lock, #endif+ ignoreSignal, defaultSignal,+#endif withFilePathException, withCEnvironment, translate, createPipe,@@ -64,7 +66,9 @@ import System.Process.Common -#ifdef WINDOWS+#if defined(javascript_HOST_ARCH)+import System.Process.JavaScript+#elif defined(WINDOWS) import System.Process.Windows #else import System.Process.Posix@@ -171,7 +175,6 @@ -> Maybe CLong -- ^ handler for SIGINT -> Maybe CLong -- ^ handler for SIGQUIT -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)--- On Windows, setting delegate_ctlc has no impact runGenProcess_ fun c (Just sig) (Just sig') | isDefaultSignal sig && sig == sig' = createProcess_ fun c { delegate_ctlc = True } runGenProcess_ fun c _ _ = createProcess_ fun c
+ System/Process/JavaScript.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}++{-+ Child process support for JavaScript running on the node.js platform.++ Other platforms such as browsers will accept the JavaScript code, but all+ operations will result in unsupported operation exceptions.+ -}++#include "HsProcessConfig.h"++module System.Process.JavaScript+ ( mkProcessHandle+ , translateInternal+ , createProcess_Internal+ , withCEnvironment+ , closePHANDLE+ , startDelegateControlC+ , endDelegateControlC+ , stopDelegateControlC+ , isDefaultSignal+ , ignoreSignal+ , defaultSignal+ , createPipeInternal+ , createPipeInternalFd+ , interruptProcessGroupOfInternal+ , getProcessId+ , getCurrentProcessId+ ) where++import Control.Concurrent.MVar+import Control.Exception (throwIO)++import Data.Char (isAlphaNum)++import System.Exit+import System.IO+import System.IO.Error+import qualified System.Posix.Internals as Posix++import Foreign.C+import Foreign.Marshal+import Foreign.Ptr++import GHC.IO.Handle.FD (mkHandleFromFD)+import GHC.IO.Device (IODeviceType(..))+import GHC.IO.Encoding (getLocaleEncoding)+import GHC.IO.Exception+import qualified GHC.IO.FD as FD++import GHC.JS.Prim++import System.Process.Common hiding (mb_delegate_ctlc, mbPipe)++mkProcessHandle :: JSVal -> Bool -> IO ProcessHandle+mkProcessHandle p mb_delegate_ctlc = do+ m <- newMVar (OpenHandle p)+ ml <- newMVar ()+ return (ProcessHandle m mb_delegate_ctlc ml)++closePHANDLE :: JSVal -> IO ()+closePHANDLE _ = return ()++getProcessId :: PHANDLE -> IO Int+getProcessId ph =+ throwErrnoIfMinus1 "getProcessId" (js_getProcessId ph)++getCurrentProcessId :: IO Int+getCurrentProcessId =+ throwErrnoIfMinus1 "getCurrentProcessId" js_getCurrentProcessId++startDelegateControlC :: IO ()+startDelegateControlC =+ throwErrnoIfMinus1_ "startDelegateControlC" js_startDelegateControlC++stopDelegateControlC :: IO ()+stopDelegateControlC =+ throwErrnoIfMinus1_ "stopDelegateControlC" js_stopDelegateControlC++endDelegateControlC :: ExitCode -> IO ()+endDelegateControlC (ExitFailure (-2)) = throwIO UserInterrupt -- SIGINT+endDelegateControlC _ = pure ()++ignoreSignal, defaultSignal :: CLong+ignoreSignal = CONST_SIG_IGN+defaultSignal = CONST_SIG_DFL++isDefaultSignal :: CLong -> Bool+isDefaultSignal = (== defaultSignal)++interruptProcessGroupOfInternal+ :: ProcessHandle -- ^ A process in the process group+ -> IO ()+interruptProcessGroupOfInternal ph =+ withProcessHandle ph $ \p_ -> do+ case p_ of+ OpenExtHandle{} -> return ()+ ClosedHandle _ -> return ()+ OpenHandle h ->+ throwErrnoIfMinus1_ "interruptProcessGroupOfInternal"+ (js_interruptProcessGroupOf h)++translateInternal :: String -> String+translateInternal "" = "''"+translateInternal str+ -- goodChar is a pessimistic predicate, such that if an argument is+ -- non-empty and only contains goodChars, then there is no need to+ -- do any quoting or escaping+ | all goodChar str = str+ | otherwise = '\'' : foldr escape "'" str+ where escape '\'' = showString "'\\''"+ escape c = showChar c+ goodChar c = isAlphaNum c || c `elem` "-_.,/"++-- node.js does not appear to have any built-in facilities+-- for creating pipes, so we leave this as an unsupported operation+-- for now+createPipeInternal :: IO (Handle, Handle)+createPipeInternal = ioError+ (ioeSetLocation unsupportedOperation "createPipeInternal")++createPipeInternalFd :: IO (Posix.FD, Posix.FD)+createPipeInternalFd = ioError+ (ioeSetLocation unsupportedOperation "createPipeInternalFd")++withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a+withCEnvironment envir act =+ let env' = map (\(name, val) -> name ++ ('=':val)) envir+ in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)++commandToProcess :: CmdSpec -> IO (FilePath, [String])+commandToProcess cmd =+ case cmd of+ ShellCommand xs -> c2p (toJSString xs) jsNull+ RawCommand c args -> c2p (toJSString c) =<< toJSStrings args+ where+ c2p c as = do+ r <- throwErrnoIfJSNull "commandToProcess" (js_commandToProcess c as)+ fromJSStrings r >>= \case+ (x:xs) -> pure (x,xs)+ _ -> error "commandToProcess: empty list"++-- -----------------------------------------------------------------------------+-- JavaScript nodejs runProcess with signal handling in the child++createProcess_Internal+ :: String+ -- ^ Function name (for error messages).+ --+ -- This can be any 'String', but will typically be the name of the caller.+ -- E.g., 'spawnProcess' passes @"spawnProcess"@ here when calling+ -- 'createProcess_'.+ -> CreateProcess+ -> IO ProcRetHandles+createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,+ cwd = mb_cwd,+ env = mb_env,+ std_in = mb_stdin,+ std_out = mb_stdout,+ std_err = mb_stderr,+ close_fds = mb_close_fds,+ create_group = mb_create_group,+ delegate_ctlc = mb_delegate_ctlc,+ new_session = mb_new_session,+ child_user = mb_child_user,+ child_group = mb_child_group }+ = do+ (cmd, args) <- commandToProcess cmdsp+ withFilePathException cmd $ do+ fdin <- mbFd fun fd_stdin mb_stdin+ fdout <- mbFd fun fd_stdout mb_stdout+ fderr <- mbFd fun fd_stderr mb_stderr+ env' <- maybe (pure jsNull)+ (toJSStrings . concatMap (\(x,y) -> [x,y]))+ mb_env++ let cwd' = maybe jsNull toJSString mb_cwd+ let c1 = toJSString cmd+ c2 <- case args of+ [] -> return jsNull+ _ -> toJSStrings args++ r <- throwErrnoIfJSNull fun $+ js_runInteractiveProcess c1+ c2+ cwd'+ env'+ fdin+ fdout+ fderr+ mb_close_fds+ mb_create_group+ mb_delegate_ctlc+ mb_new_session+ (maybe (-1) fromIntegral mb_child_group)+ (maybe (-1) fromIntegral mb_child_user)++ fdin_r:fdout_r:fderr_r:_ <-+ map (stdFD . fromIntegral) <$> (fromJSInts =<< getProp r "fds")++ hndStdInput <- mbPipe mb_stdin fdin_r WriteMode+ hndStdOutput <- mbPipe mb_stdout fdout_r ReadMode+ hndStdError <- mbPipe mb_stderr fderr_r ReadMode++ ph <- mkProcessHandle r mb_delegate_ctlc+ return $ ProcRetHandles { hStdInput = hndStdInput+ , hStdOutput = hndStdOutput+ , hStdError = hndStdError+ , procHandle = ph+ }++mbPipe :: StdStream -> FD.FD -> IOMode -> IO (Maybe Handle)+mbPipe CreatePipe fd mode = do+ enc <- getLocaleEncoding+ fmap Just (mkHandleFromFD fd+ Stream+ ("fd: " ++ show fd)+ mode+ False {-is_socket-}+ (Just enc))+mbPipe _ _ _ = do+ return Nothing++stdFD :: CInt -> FD.FD+stdFD fd = FD.FD { FD.fdFD = fd+ , FD.fdIsNonBlocking = 0+ }++-- -----------------------------------------------------------------------------+-- Some helpers for dealing with JavaScript values++-- JavaScript value type synonyms, for readability+type JSArray = JSVal+type JSString = JSVal++fromJSStrings :: JSVal -> IO [String]+fromJSStrings x = fmap (map fromJSString) (fromJSArray x)++fromJSInts :: JSVal -> IO [Int]+fromJSInts x = map fromJSInt <$> fromJSArray x++toJSStrings :: [String] -> IO JSVal+toJSStrings xs = toJSArray (map toJSString xs)++throwErrnoIfJSNull :: String -> IO JSVal -> IO JSVal+throwErrnoIfJSNull msg m = do+ r <- m+ if isNull r then throwErrno msg+ else return r++-- -----------------------------------------------------------------------------+-- Foreign imports from process.js++-- run an interactive process. Note that this foreign import is asynchronous+-- (interruptible) since it waits until the process has spawned (or an error+-- has occurred.+--+-- this should only be a short time, so it should be safe to call this from+-- an uninterruptible mask.++foreign import javascript interruptible "h$process_runInteractiveProcess"+ js_runInteractiveProcess+ :: JSString -- ^ command or program+ -> JSArray -- ^ arguments, null if it's a raw command+ -> JSString -- ^ working dir, null for current+ -> JSArray -- ^ environment, null for existing+ -> CInt -- ^ stdin fd+ -> CInt -- ^ stdout fd+ -> CInt -- ^ stderr fd+ -> Bool -- ^ close file descriptors in child (currently unsupported)+ -> Bool -- ^ create a new process group+ -> Bool -- ^ delegate ctrl-c+ -> Bool -- ^ create a new session+ -> Int -- ^ set child GID (-1 for unchanged)+ -> Int -- ^ set child UID (-1 for unchanged)+ -> IO JSVal -- ^ process handle (null if an error occurred)++foreign import javascript safe "h$process_commandToProcess"+ js_commandToProcess+ :: JSString+ -> JSArray+ -> IO JSArray++foreign import javascript unsafe "h$process_interruptProcessGroupOf"+ js_interruptProcessGroupOf+ :: PHANDLE+ -> IO Int++foreign import javascript unsafe "h$process_startDelegateControlC"+ js_startDelegateControlC+ :: IO Int++foreign import javascript unsafe "h$process_stopDelegateControlC"+ js_stopDelegateControlC+ :: IO Int++foreign import javascript unsafe "h$process_getCurrentProcessId"+ js_getCurrentProcessId+ :: IO Int++foreign import javascript unsafe "h$process_getProcessId"+ js_getProcessId+ :: PHANDLE+ -> IO Int
System/Process/Windows.hsc view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE InterruptibleFFI #-} module System.Process.Windows ( mkProcessHandle@@ -22,6 +23,7 @@ import System.Process.Common import Control.Concurrent import Control.Exception+import Control.Monad import Data.Bits import Foreign.C import Foreign.Marshal@@ -65,14 +67,14 @@ -- On Windows, we have to close this HANDLE when it is no longer required, -- hence we add a finalizer to it-mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle-mkProcessHandle h job = do+mkProcessHandle :: PHANDLE -> Bool -> PHANDLE -> IO ProcessHandle+mkProcessHandle h ignore_signals job = do m <- if job == nullPtr then newMVar (OpenHandle h) else newMVar (OpenExtHandle h job) _ <- mkWeakMVar m (processHandleFinaliser m) l <- newMVar ()- return (ProcessHandle m False l)+ return (ProcessHandle m ignore_signals l) processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m =@@ -114,7 +116,6 @@ std_err = mb_stderr, close_fds = mb_close_fds, create_group = mb_create_group,- delegate_ctlc = _ignored, detach_console = mb_detach_console, create_new_console = mb_create_new_console, new_session = mb_new_session,@@ -166,7 +167,7 @@ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env,- delegate_ctlc = _ignored }+ delegate_ctlc = ignore_signals } action = do let lenPtr = sizeOf (undefined :: WordPtr)@@ -183,8 +184,15 @@ (proc_handle, hndStdInput, hndStdOutput, hndStdError) <- action pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline + -- If we have successfully created the process then check if we have to+ -- detach from the console. I'm not sure why the posix version changes+ -- the state right before creating the child process, but doing so here+ -- means the first child also inherits this+ when ignore_signals $+ startDelegateControlC+ phJob <- peek hJob- ph <- mkProcessHandle proc_handle phJob+ ph <- mkProcessHandle proc_handle ignore_signals phJob return ProcRetHandles { hStdInput = hndStdInput , hStdOutput = hndStdOutput , hStdError = hndStdError@@ -203,7 +211,6 @@ std_err = mb_stderr, close_fds = mb_close_fds, create_group = mb_create_group,- delegate_ctlc = _ignored, detach_console = mb_detach_console, create_new_console = mb_create_new_console, new_session = mb_new_session,@@ -260,19 +267,72 @@ runInteractiveProcess_lock :: MVar () runInteractiveProcess_lock = unsafePerformIO $ newMVar () --- The following functions are always present in the export list. For--- compatibility with the non-Windows code, we provide the same functions with--- matching type signatures, but implemented as no-ops. For details, see:--- <https://github.com/haskell/process/pull/21>+-- ----------------------------------------------------------------------------+-- Delegated control-C handling on Windows++-- See https://learn.microsoft.com/en-us/windows/console/setconsolectrlhandler+--+-- While running an interactive console process like ghci or a shell, we want+-- to let that process handle Ctl-C keyboard interrupts how it sees fit.+-- So that means we need to ignore the CTRL_C_EVENT/CTRL_BREAK_EVENT Windows+-- events while we're running such programs.+--+-- If we run multiple programs like this concurrently then we have to be+-- careful to avoid messing up the signal handlers. We keep a count and only+-- restore when the last one has finished.+--+-- To do this we have to use SetConsoleCtrlHandler which masks the events for+-- the current process and any child it creates from that point.+--+-- In this case we can't use FreeConsole/AttachConsole since those destroy+-- the signal handler stack for the application when called. This means we'd+-- have to recreate them and process doesn't know what's there.++{-# NOINLINE runInteractiveProcess_delegate_ctlc #-}+runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int))+runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing+ startDelegateControlC :: IO ()-startDelegateControlC = return ()+startDelegateControlC =+ modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do+ case delegating of+ Nothing -> do+ -- We're going to ignore ^C in the parent while there are any+ -- processes using ^C delegation.+ --+ -- If another thread runs another process without using+ -- delegation while we're doing this then it will inherit the+ -- ignore ^C status.+ _ <- c_setConsoleCtrlHandler nullPtr True+ return (Just 1) -endDelegateControlC :: ExitCode -> IO ()-endDelegateControlC _ = return ()+ Just count -> do+ -- If we're already doing it, just increment the count+ let !count' = count + 1+ return (Just count') stopDelegateControlC :: IO ()-stopDelegateControlC = return ()+stopDelegateControlC =+ modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do+ case delegating of+ Just 1 -> do+ -- Last process, so restore the old signal handlers+ _ <- c_setConsoleCtrlHandler nullPtr False+ return Nothing + Just count -> do+ -- Not the last, just decrement the count+ let !count' = count - 1+ return (Just count')++ Nothing -> return Nothing -- should be impossible++endDelegateControlC :: ExitCode -> IO ()+-- I don't think there's a standard exit code for program interruptions+-- on Windows, so I'll just ignore it for now.+endDelegateControlC _ = stopDelegateControlC++ -- End no-op functions @@ -306,6 +366,12 @@ c_terminateJobObject :: PHANDLE -> CUInt+ -> IO Bool++foreign import WINDOWS_CCONV unsafe "SetConsoleCtrlHandler"+ c_setConsoleCtrlHandler+ :: Ptr ()+ -> Bool -> IO Bool foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
cbits/posix/find_executable.c view
@@ -53,10 +53,12 @@ * found. */ static char *find_in_search_path(char *working_dir, char *search_path, const char *filename) {- int workdir_len = strlen(working_dir); const int filename_len = strlen(filename); char *tokbuf; char *path = strtok_r(search_path, ":", &tokbuf);+ if (!working_dir)+ working_dir = ".";+ int workdir_len = strlen(working_dir); while (path != NULL) { // N.B. gcc 6.3.0, used by Debian 9, inexplicably warns that `path` // may not be initialised with -Wall. Silence this warning. See #210.
cbits/posix/fork_exec.c view
@@ -1,6 +1,11 @@-/* ensure that execvpe is provided if possible */+/* Ensure that execvpe and pipe2 are provided if possible */ #define _GNU_SOURCE 1 +/* Ensure getpwuid_r(3) is available on Solaris. */+#if defined(__sun)+#define _POSIX_PTHREAD_SEMANTICS+#endif+ #include "common.h" #if defined(HAVE_FORK)@@ -24,18 +29,9 @@ #include <signal.h> #endif -#if defined(HAVE_VFORK_H)-#include <vfork.h>-#endif- #include <Rts.h> -#if defined(HAVE_WORKING_VFORK)-#define myfork vfork-#elif defined(HAVE_WORKING_FORK)-#define myfork fork-// We don't need a fork command on Windows-#else+#if !defined(HAVE_WORKING_FORK) #error Cannot find a working fork command #endif @@ -65,7 +61,7 @@ { switch (b->behavior) { case STD_HANDLE_CLOSE:- if (close(fd) == -1) {+ if (close(fd) == -1 && errno != EBADF) { child_failed(pipe, "close"); } return 0;@@ -102,6 +98,28 @@ } } +/* This will `dup` the given fd such that it does not fall in the range of+ * stdin/stdout/stderr, if necessary. The new handle will have O_CLOEXEC.+ *+ * This is necessary as we must ensure that the fork communications pipe does+ * not inhabit fds 0 through 2 since we will need to manipulate these fds in+ * setup_std_handle_fork while keeping the pipe available so that it can report+ * errors. See #266.+ */+int unshadow_pipe_fd(int fd, char **failed_doing) {+ if (fd > 2) {+ return fd;+ }++ int new_fd = fcntl(fd, F_DUPFD_CLOEXEC, 3);+ if (new_fd == -1) {+ *failed_doing = "fcntl(F_DUP_FD)";+ return -1;+ }+ close(fd);+ return new_fd;+}+ /* Try spawning with fork. */ ProcHandle do_spawn_fork (char *const args[],@@ -114,22 +132,27 @@ char **failed_doing) { int forkCommunicationFds[2];- int r = pipe(forkCommunicationFds);+ int r;++#if defined(HAVE_PIPE2)+ r = pipe2(forkCommunicationFds, O_CLOEXEC);+#else+ r = pipe(forkCommunicationFds);+#endif if (r == -1) { *failed_doing = "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();-- // See #4074. Sometimes fork() gets interrupted by the timer- // signal and keeps restarting indefinitely.- stopTimer();+ // Ensure that the pipe fds don't shadow stdin/stdout/stderr+ forkCommunicationFds[0] = unshadow_pipe_fd(forkCommunicationFds[0], failed_doing);+ if (forkCommunicationFds[0] == -1) {+ return -1;+ }+ forkCommunicationFds[1] = unshadow_pipe_fd(forkCommunicationFds[1], failed_doing);+ if (forkCommunicationFds[1] == -1) {+ return -1;+ } // N.B. execvpe is not supposed on some platforms. In this case // we emulate this using fork and exec. However, to safely do so@@ -147,7 +170,18 @@ } #endif - int pid = myfork();+ // 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();++ // See #4074. Sometimes fork() gets interrupted by the timer+ // signal and keeps restarting indefinitely.+ stopTimer();++ int pid = fork(); switch(pid) { case -1:@@ -159,10 +193,6 @@ return -1; case 0:- // WARNING! We may now be in the child of vfork(), and any- // memory we modify below may also be seen in the parent- // process.- close(forkCommunicationFds[0]); fcntl(forkCommunicationFds[1], F_SETFD, FD_CLOEXEC);
cbits/win32/runProcess.c view
@@ -617,7 +617,22 @@ return true; } - HANDLE pHwnd = OpenProcess(SYNCHRONIZE, TRUE, pid_list->ProcessIdList[0]);+ HANDLE pHwnd;+ bool found_p;++ /* Find the first non-terminated handle. */+ for (DWORD i = 0; i < pid_list->NumberOfProcessIdsInList; i++) {+ pHwnd = OpenProcess(SYNCHRONIZE, FALSE, pid_list->ProcessIdList[i]);+ int code = 0;+ found_p = pHwnd && getProcessExitCode (pHwnd, &code) != -1 && code != STILL_ACTIVE;+ if (found_p)+ break;+ }++ /* All processes were terminated already. */+ if (!found_p)+ return true;+ if (pHwnd == NULL) { switch (GetLastError()) { case ERROR_INVALID_PARAMETER:@@ -632,7 +647,13 @@ } // Wait for it to finish...- if (WaitForSingleObject(pHwnd, INFINITE) != WAIT_OBJECT_0) {+ DWORD result = WaitForSingleObject(pHwnd, 200);+ if (result == WAIT_TIMEOUT) {+ int code = 0;+ /* Current process is waiting to terminate. skip. */+ if (getProcessExitCode (pHwnd, &code) != -1 && code != STILL_ACTIVE)+ continue ;+ } else if (result != WAIT_OBJECT_0) { free(pid_list); maperrno(); CloseHandle(pHwnd);
changelog.md view
@@ -1,5 +1,13 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.18.0 *September 2023*++* Fix deadlock when waiting for process completion and process jobs [#273](https://github.com/haskell/process/issues/273)+* Support `delegate_ctlc` on Windows. [#278](https://github.com/haskell/process/pull/278)+* Drop support for `vfork` [#261](https://github.com/haskell/process/pull/261)+* Javascript backend support+* Fix potential segmentation fault on macOS [#295](https://github.com/haskell/process/pull/295)+ ## 1.6.17.0 *February 2023* * Improved documentation for the `OpenExtHandle` constructor.
configure view
@@ -3959,6 +3959,13 @@ fi +ac_fn_c_check_func "$LINENO" "pipe2" "ac_cv_func_pipe2"+if test "x$ac_cv_func_pipe2" = xyes+then :+ printf "%s\n" "#define HAVE_PIPE2 1" >>confdefs.h++fi+ # posix_spawn checks ac_fn_c_check_header_compile "$LINENO" "spawn.h" "ac_cv_header_spawn_h" "$ac_includes_default"
configure.ac view
@@ -7,7 +7,7 @@ AC_PROG_CC -dnl ** Working vfork?+dnl ** Working fork? AC_FUNC_FORK # check for specific header (.h) files that we are interested in@@ -15,6 +15,11 @@ AC_CHECK_FUNCS([setitimer sysconf]) AC_CHECK_FUNCS([execvpe])+AC_CHECK_FUNCS([pipe2],[],[],[+ #define _GNU_SOURCE+ #include <unistd.h>+ #include <fcntl.h>+]) # posix_spawn checks AC_CHECK_HEADERS([spawn.h])
include/HsProcessConfig.h.in view
@@ -30,6 +30,9 @@ /* Define to 1 if you have the <inttypes.h> header file. */ #undef HAVE_INTTYPES_H +/* Define to 1 if you have the `pipe2' function. */+#undef HAVE_PIPE2+ /* Define to 1 if you have the `posix_spawnp' function. */ #undef HAVE_POSIX_SPAWNP
+ jsbits/process.js view
@@ -0,0 +1,581 @@+//#OPTIONS: CPP++// #define JS_TRACE_PROCESS 1++#ifdef JS_TRACE_PROCESS+function h$logProcess() { h$log.apply(h$log,arguments); }+#define TRACE_PROCESS(args...) h$logProcess(args)+#else+#define TRACE_PROCESS(args...)+#endif++/*+ Convert from a string signal name to a signal number.++ To ensure consistent signal numbers between platforms we use signal+ numbers from the emscripten SDK whenever we use a numeric signal code.++ These might differ from the actual numbers of the operating system+ on which the nodejs process is running.++ list from emscripten /system/lib/libc/musl/arch/emscripten/bits/signal.h++ Note: we should possibly move this into the base or rts package in the future+ */+var h$process_signals = {+ 'SIGHUP': 1,+ 'SIGINT': 2,+ 'SIGQUIT': 3,+ 'SIGILL': 4,+ 'SIGTRAP': 5,+ 'SIGABRT': 6,+ 'SIGIOT': 6,+ 'SIGBUS': 7,+ 'SIGFPE': 8,+ 'SIGKILL': 9,+ 'SIGUSR1': 10,+ 'SIGSEGV': 11,+ 'SIGUSR2': 12,+ 'SIGPIPE': 13,+ 'SIGALRM': 14,+ 'SIGTERM': 15,+ 'SIGSTKFLT': 16,+ 'SIGCHLD': 17,+ 'SIGCONT': 18,+ 'SIGSTOP': 19,+ 'SIGTSTP': 20,+ 'SIGTTIN': 21,+ 'SIGTTOU': 22,+ 'SIGURG': 23,+ 'SIGXCPU': 24,+ 'SIGXFSZ': 25,+ 'SIGVTALRM': 26,+ 'SIGPROF': 27,+ 'SIGWINCH': 28,+ 'SIGIO': 29,+ 'SIGPOLL': 29,+ 'SIGPWR': 30,+ 'SIGSYS': 31,+ 'SIGUNUSED': 31+};++/*+ Create a one-directional pipe for communication with the child process++ - pipe: a Readable or Writable stream from spawning the child process+ - write: boolean - true if the pipe is for writing, false for reading+ */+function h$process_pipeFd(pipe, write) {+ var fdN = h$base_fdN--, fd = {};+ h$base_fds[fdN] = fd;+ TRACE_PROCESS("pipe", fdN, "opened, writable:", write);++ if(pipe && pipe._handle && typeof pipe._handle.fd === 'number') fd.fd = pipe._handle.fd;+ TRACE_PROCESS("pipe real fd", fd.fd);++ if(write) {+ fd.err = null;+ fd.waiting = new h$Queue();+ fd.close = function(fd, fdo, c) { delete h$base_fds[fd]; pipe.end(); c(0); };+ fd.refs = 1;+ pipe.on('error', function(err) {+ TRACE_PROCESS("pipe received error", fd, err);+ fd.err = err;+ });+ fd.write = function(fd, fdo, buf, buf_offset, n, c) {+ TRACE_PROCESS("pipe ", fd, " write:", n);+ if(fdo.err) {+ TRACE_PROCESS("pipe error", fdo.err);+ h$setErrno(fdo.err);+ c(-1);+ return;+ }+ var nbuf = buf.u8.slice(buf_offset, buf_offset+n);+ var r = pipe.write(nbuf, function() {+ TRACE_PROCESS("pipe", fd, "flushed");+ c(n);+ });+ TRACE_PROCESS("pipe write", fd, "result", r);+ }+ } else {+ fd.close = function(fd, fdo, c) { delete h$base_fds[fd]; c(0); }+ fd.refs = 1;+ fd.waiting = new h$Queue();+ fd.chunk = { buf: null, pos: 0, processing: false };+ fd.eof = false;+ fd.err = null;+ fd.reading = false;++ pipe.on('end', function() {+ TRACE_PROCESS("pipe", fdN, fd.fd, "eof");+ fd.eof = true;+ h$process_process_pipe(fd, pipe);+ });+ pipe.on('error', function(err) {+ TRACE_PROCESS("pipe received error", fdN, fd.fd);+ fd.err = err;+ h$process_process_pipe(fd, pipe);+ });+ fd.read = function(fd, fdo, buf, buf_offset, n, c) {+ if(!fdo.reading) {+ /*+ Reading is a blocking operation (asynchronous) from the Haskell+ side. On the JavaScript side we rely on the 'readable' event to+ know when there is available data. Every time data comes in we+ process the queue of waiting read requests.++ We don't attach the 'readable' event handler until we actually+ read from the pipe, since the readable handler causes the node.js+ process to start buffering data from the file descriptor.++ If we don't read from the file descriptor it is unaffected by+ node.js buffering and we can for example pass it to another child+ process to allow direct communication between multiple child+ processes.+ */+ pipe.on('readable', function() {+ TRACE_PROCESS("pipe", fdN, fd.fd, "readable");+ h$process_process_pipe(fdo, pipe);+ });+ fdo.reading = true;+ h$process_process_pipe(fdo, pipe);+ }+ TRACE_PROCESS("pipe", fdN, fd.fd, "read", n, fdo.chunk.buf);+ fdo.waiting.enqueue({buf: buf, off: buf_offset, n: n, c: c});+ h$process_process_pipe(fdo, pipe);+ }+ }+ TRACE_PROCESS("created pipe, fd:", fdN);+ return fdN;+}++/*+ Process the queue of waiting read/write requests for a pipe+ */+function h$process_process_pipe(fd, pipe) {+ var c = fd.chunk;+ var q = fd.waiting;+ TRACE_PROCESS("processing pipe", fd);+ if(!q || !q.length() || c.processing) return;+ c.processing = true;+ while(fd.err && q.length()) {+ h$setErrno(fd.err);+ q.dequeue().c(-1);+ }+ if(!c.buf) {+ c.pos = 0;+ c.buf = pipe.read();+ }+ while(c.buf && q.length()) {+ var x = q.dequeue();+ var n = Math.min(c.buf.length - c.pos, x.n);+ for(var i=0;i<n;i++) {+ x.buf.u8[i+x.off] = c.buf[c.pos+i];+ }+ c.pos += n;+ x.c(n);+ // XXX this does reorder the requests if data comes in small chunks+ if(c.pos >= c.buf.length) c.buf = null;+ if(!c.buf && q.length()) {+ c.pos = 0;+ c.buf = pipe.read();+ }+ }+ while(fd.eof && q.length()) q.dequeue().c(0);+ TRACE_PROCESS("done processing pipe, remaining queue", q.length());+ c.processing = false;+}++/*+ Start an interactive child process using the node.js child_prcess.spawn+ functionality.++ Even though this is mostly a non-blocking operation (we don't wait until+ the child process has finished), this is an asynchronous function+ (with a continuation) because we want to wait until the child process has+ spawned before we resume the Haskell thread.++ This allows us to raise exceptions if the process could not be started, for+ example becaus of permission errors or a non-existent executable.++ Calls the continuation with a process object, or null when spawning the+ process has failed, after setting h$errno to the appropriate value.+ */+function h$process_runInteractiveProcess(+ cmd // string - command to run+ , args // array of strings - arguments+ , workingDir // string - working directory, null: unchanged+ , env // array of strings - environment [ key1, val1, key2, val2, ...]+ // null: inherit+ , stdin_fd // number - stdin fd, -1: createpipe, -2: ignore+ , stdout_fd // number - stdout fd, -1: createpipe, -2: ignore+ , stderr_fd // number - stderr fd, -1: createpipe, -2: ignore+ , _closeFds // boolean - close file descriptors in child (ignored)+ , createGroup // boolean - create a new process group+ , delegateCtlC // boolean - delegate control-C handling+ , newSession // boolean - use posix setsid to start the process in a new session+ , childGID // number - child group id, -1 for unchanged+ , childUID // number - child user id, -1 for unchanged+ , c // function - continuation, called when the process has spawned+ ) {+ TRACE_PROCESS("runInteractiveProcess");+ TRACE_PROCESS("cmd: ", cmd, " args: ", args);+ TRACE_PROCESS("workingDir: ", workingDir, " env: ", env);+ TRACE_PROCESS("stdin", stdin_fd, "stdout", stdout_fd, "stderr", stderr_fd);++ if(h$isNode()) {+ try {+ var stdin_p, stdout_p, stderr_p;++ function getStream(pos, spec) {+ // CreatePipe+ if(spec === -1) return 'pipe';++ // NoStream+ if(spec === -2) return 'ignore';++ // standard streams+ if(spec === 0) return spec == pos ? 'inherit' : process.stdin;+ if(spec === 1) return spec == pos ? 'inherit' : process.stdout;+ if(spec === 2) return spec == pos ? 'inherit' : process.stderr;++ // registered fd+ var stream = h$base_fds[spec];+ if(typeof stream.fd === 'number') return stream.fd;++ // raw fd+ if(typeof spec === 'number' && spec > 0) return spec;++ // unsupported stream type+ // the exception is caught and converted to an errno status code below+ throw new Error('EBADF');+ }++ stdin_p = getStream(0, stdin_fd);+ stdout_p = getStream(1, stdout_fd);+ stderr_p = getStream(2, stderr_fd);++ var options = { detached: newSession || createGroup+ , stdio: [stdin_p, stdout_p, stderr_p]+ };+ if(workingDir !== null) options.cwd = workingDir;+ if(env !== null) {+ var envObj = {};+ for(var i=0;i<env.length;i+=2) envObj[env[i]] = env[i+1];+ TRACE_PROCESS("environment: " + h$collectProps(envObj));+ options.env = envObj;+ }+ if(childGID !== -1) options.gid = childGID;+ if(childUID !== -1) options.uid = childUID;++ var procObj;+ var child;++ // node.js on Windows x86 sometimes throw an EBADF exception when+ // process.stdin is invalid, retry with ignored stdin when+ // this happens.+ TRACE_PROCESS("spawning process", cmd, args, options);++ try {+ child = h$child.spawn(cmd, args, options);+ } catch(e) {+ TRACE_PROCESS("spawning exception", e);++ if(e.toString().indexOf('EBADF') !== -1 && options.stdio[0] === process.stdin) {+ options.stdio[0] = 'ignore';+ child = h$child.spawn(cmd, args, options);+ } else {+ throw e;+ }+ }+ TRACE_PROCESS("spawn done, setting handlers");++ // keep track of whether the process has spawned, since we can get+ // multiple events for this and we only want to call the continuation+ // once.+ var spawned = false;++ child.on('exit', function(code, sig) {+ TRACE_PROCESS("process finished", code, sig);+ // if the spawn event hasn't fired we still have to call+ // the continuation for that+ if(!spawned) {+ spawned = true;+ c(procObj);+ } else {+ if(delegateCtlC) {+ h$process_stopDelegateControlC();+ }+ }+ if(code === null) {+ // process was killed by a signal+ var signo = h$process_signals[sig] || 31;+ // The Haskell side expects a negative status if killed+ // by a signal+ code = -signo;+ }+ procObj.exit = code;++ // notify all threads that are waiting for the exit code+ for(var i=0;i<procObj.waiters.length;i++) {+ procObj.waiters[i](code);+ }+ });++ child.on('spawn', function() {+ TRACE_PROCESS("process spawned");+ if(!spawned) {+ if(delegateCtlC) {+ h$process_startDelegateControlC();+ }+ spawned = true;+ c(procObj);+ }+ });++ child.on('error', function(e) {+ TRACE_PROCESS("process errored:", e);+ if(!spawned) {+ // if the process hasn't spawned yet we can raise an exception+ // immediately++ // prevent subsequent calls to the continuation+ spawned = true;++ h$setErrno(e);+ c(null);+ } else {+ /*+ Convert the node.js status code string to the appropriate+ (emscripten SDK) numeric error code.++ We should add a way to get the error code from the+ string without modifying the global h$errno value+ */+ var currentErrno = h$errno;+ h$setErrno(e.code);+ var code = h$errno;+ h$errno = currentErrno;++ procObj.exit = code;+ for(var i=0;i<procObj.waiters.length;i++) {+ procObj.waiters[i](code);+ }+ }+ });++ procObj = { fds: [ stdin_fd === -1 ? h$process_pipeFd(child.stdio[0], true) : null+ , stdout_fd === -1 ? h$process_pipeFd(child.stdio[1], false) : null+ , stderr_fd === -1 ? h$process_pipeFd(child.stdio[2], false) : null+ ]+ , exit: null+ , waiters : []+ , child: child+ };+ TRACE_PROCESS("process object created:", procObj);++ // sometimes the process has already spawned before we attach the 'spawn` event handler,+ // check here if it already has a pid and immediately call the continuation if that's the+ // case+ if(typeof child.pid === 'number') {+ TRACE_PROCESS("process spawned immediately", child.pid);++ spawned = true;+ c(procObj);+ }++ } catch(e) {+ TRACE_PROCESS("catch:", e);+ spawned = true;+ h$setErrno(e);+ c(null);+ }+ } else { // h$isNode+ h$unsupported(null, c);+ }+}++/*+ return the thing to run as an array, first element the process,+ followed by the the args. null if no interpreter can be found++ - cmd: string - the command to run+ - args: array of string - arguments, null to run cmd as a shell command+ in an interpreter.+ */+function h$process_commandToProcess(cmd, args) {+ if(h$isNode()) {+ TRACE_PROCESS("commandToProcess: ", cmd, args);+ if(process.platform === 'win32') {+ if(args === null) { // shellcmd+ var com = process.env['COMSPEC'];+ /*+ Note: The old GHCJS code had a fallback using code from+ the directory package (h$directory_findExecutables).+ Here we just produce an error if COMSPEC is not set,+ since we don't have the code from the directory package+ available.+ If needed we could implement similar functionality here.+ */+ if(!com) {+ h$setErrno('ENOENT');+ return null;+ }+ return [com, " /c " + cmd];+ } else {+ var r = [cmd];+ r = r.concat(args);+ return r;+ }+ } else { // non-windows+ if(args === null) { // shellcmd+ return ["/bin/sh", "-c", cmd];+ } else {+ var r = [cmd];+ r = r.concat(args);+ return r;+ }+ }+ } else {+ return h$unsupported(null);+ }+}+/*+ Send the SIGTERM signal to the child process+ */+function h$process_terminateProcess(ph) {+ TRACE_PROCESS("terminateProcess", ph);+ if(h$isNode()) {+ ph.child.kill();+ return 0;+ } else {+ return h$unsupported(1);+ }+}++/*+ Get the process exit code. Does not block.++ - returns 0 if the process has not exited yet.+ - returns 1 and saves the exit code in the code_d pointer otherwise+ */+function h$process_getProcessExitCode(ph, code_d, code_o) {+ TRACE_PROCESS("getProcessExitCode", ph);+ if(ph.exit === null) return 0;+ code_d.i3[code_o>>2] = ph.exit;+ return 1;+}++/*+ Wait for the process to finish and return the exit code.+ */+function h$process_waitForProcess(ph, code_d, code_o, c) {+ TRACE_PROCESS("waitForProcess", ph);+ if(h$isNode()) {+ if(ph.exit !== null) {+ h$process_getProcessExitCode(ph, code_d, code_o);+ c(0);+ } else {+ ph.waiters.push(function(code) {+ code_d.i3[code_o>>2] = code;+ c(0);+ });+ }+ } else {+ h$unsupported(-1, c);+ }+}++function h$process_interruptProcessGroupOf(ph) {+ TRACE_PROCESS("interruptProcessGroupOf", ph);+ if(h$isNode()) {+ // there doesn't appear to be a way to find the process+ // group id from a process id (ph.child.pid) on nodejs,+ // so this operation is unsupported.+ return h$unsupported(-1);+ } else {+ return h$unsupported(-1);+ }+}++var h$process_delegateControlCCount = 0;++/*+ We install a signal handler that ignores SIGINT/SIGQUIT while+ delegating ctl-c handling.++ This keeps the current node.js process running and propagates the+ signal to the child processes in the same group.+ */+function h$process_ignoreSIG() {+ TRACE_PROCESS("process_ignoreSIG: ignoring signal");+ return 0;+}++/*+ Start delegating ctl-c handling. Installs the above handler if this is the+ first process for which delegation is needed.+ */+function h$process_startDelegateControlC() {+ TRACE_PROCESS("startDelegateControlC", h$process_delegateControlCCount);+ if(h$isNode()) {+ if(h$process_delegateControlCCount === 0) {+ TRACE_PROCESS("startDelegateControlC: installing handler")+ process.on('SIGINT', h$process_ignoreSIG);+ process.on('SIGQUIT', h$process_ignoreSIG);++ }+ h$process_delegateControlCCount++;+ return 0;+ } else {+ return h$unsupported(-1);+ }+}++/*+ Stop delegating ctrl-c handling. Removes the above handler if this is the+ last process for which delegation is needed.+ */+function h$process_stopDelegateControlC() {+ TRACE_PROCESS("stopDelegateControlC", h$process_delegateControlCCount);+ if(h$isNode()) {+ if(h$process_delegateControlCCount > 0) {+ h$process_delegateControlCCount--;+ if(h$process_delegateControlCCount === 0) {+ TRACE_PROCESS("stopDelegateControlC: removing handler")+ process.off('SIGINT', h$process_ignoreSIG);+ process.off('SIGQUIT', h$process_ignoreSIG);+ }+ }+ return 0;+ } else {+ return h$unsupported(-1);+ }+}++/*+ Get the process id of the current (node.js) process+ */+function h$process_getCurrentProcessId() {+ TRACE_PROCESS("getCurrentProcessId");+ if(h$isNode()) {+ return process.pid;+ } else {+ return h$unsupported(-1);+ }+}++/*+ Get the process id of a child process+ */+function h$process_getProcessId(ph) {+ TRACE_PROCESS("getProcessId", ph);+ if(ph && typeof ph === 'object' &&+ ph.child && typeof ph.child == 'object' &&+ typeof ph.child.pid == 'number') {+ return ph.child.pid;+ } else {+ h$setErrno('EBADF');+ return -1;+ }+}
process.cabal view
@@ -1,5 +1,5 @@ name: process-version: 1.6.17.0+version: 1.6.18.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE@@ -64,13 +64,18 @@ extra-libraries: kernel32, ole32, rpcrt4 cpp-options: -DWINDOWS else- c-sources:- cbits/posix/runProcess.c- cbits/posix/fork_exec.c- cbits/posix/posix_spawn.c- cbits/posix/find_executable.c- other-modules: System.Process.Posix- build-depends: unix >= 2.5 && < 2.9+ if arch(javascript)+ js-sources:+ jsbits/process.js+ other-modules: System.Process.JavaScript+ else+ c-sources:+ cbits/posix/runProcess.c+ cbits/posix/fork_exec.c+ cbits/posix/posix_spawn.c+ cbits/posix/find_executable.c+ other-modules: System.Process.Posix+ build-depends: unix >= 2.5 && < 2.9 include-dirs: include includes:@@ -81,10 +86,10 @@ ghc-options: -Wall - build-depends: base >= 4.10 && < 4.19,+ build-depends: base >= 4.10 && < 4.20, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5,- deepseq >= 1.1 && < 1.5+ deepseq >= 1.1 && < 1.6 test-suite test default-language: Haskell2010
test/main.hs view
@@ -41,6 +41,7 @@ testInterruptWith testDoubleWait testKillDoubleWait+ testCreateProcess putStrLn ">>> Tests passed successfully" run :: String -> IO () -> IO ()@@ -250,6 +251,33 @@ checkSecond sig delegate res = case (sig, delegate) of ("INT", True) -> checkFirst "INT" False res _ -> checkFirst sig delegate res++-- Test that createProcess doesn't segfault on Mac with a cwd of Nothing+testCreateProcess :: IO ()+testCreateProcess = run "createProcess with cwd = Nothing" $ do+ let env = CreateProcess+ { child_group = Nothing+ , child_user = Nothing+ , close_fds = False+ , cmdspec = RawCommand "env" []+ , create_group = True+ , create_new_console = False+ , cwd = Nothing+ , delegate_ctlc = False+ , detach_console = False+ , env = Just [("PATH", "/bin:/usr/bin")]+ , new_session = False+ , std_err = Inherit+ , std_in = Inherit+ , std_out = Inherit+ , use_process_jobs = False+ }+ (_, _, _, p) <- createProcess env+ res <- try $ waitForProcess p+ case res of+ Left e -> error $ "waitForProcess threw: " ++ show (e :: SomeException)+ Right ExitSuccess -> return ()+ Right exitCode -> error $ "unexpected exit code: " ++ show exitCode withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory new inner = do