diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -8,6 +8,10 @@ #include +#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 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,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 diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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 diff --git a/System/Process/JavaScript.hs b/System/Process/JavaScript.hs new file mode 100644 --- /dev/null +++ b/System/Process/JavaScript.hs @@ -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 diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -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: --- +-- ---------------------------------------------------------------------------- +-- 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 diff --git a/cbits/posix/find_executable.c b/cbits/posix/find_executable.c --- a/cbits/posix/find_executable.c +++ b/cbits/posix/find_executable.c @@ -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. diff --git a/cbits/posix/fork_exec.c b/cbits/posix/fork_exec.c --- a/cbits/posix/fork_exec.c +++ b/cbits/posix/fork_exec.c @@ -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 #endif -#if defined(HAVE_VFORK_H) -#include -#endif - #include -#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); diff --git a/cbits/win32/runProcess.c b/cbits/win32/runProcess.c --- a/cbits/win32/runProcess.c +++ b/cbits/win32/runProcess.c @@ -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); diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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 + #include +]) # posix_spawn checks AC_CHECK_HEADERS([spawn.h]) diff --git a/include/HsProcessConfig.h.in b/include/HsProcessConfig.h.in --- a/include/HsProcessConfig.h.in +++ b/include/HsProcessConfig.h.in @@ -30,6 +30,9 @@ /* Define to 1 if you have the 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 diff --git a/jsbits/process.js b/jsbits/process.js new file mode 100644 --- /dev/null +++ b/jsbits/process.js @@ -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= 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>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; + } +} diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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