From e9a151ed288ac5696f631f5ae3fec12dd44abb8a Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 20 Jun 2023 23:05:48 +0900 Subject: [PATCH 1/5] Add JavaScript support This adds support for the GHC JavaScript backend. The resulting code can be run on node.js. --- System/Process.hs | 52 +++- System/Process/Common.hs | 26 +- System/Process/Internals.hs | 8 +- System/Process/JavaScript.hs | 308 ++++++++++++++++++ jsbits/process.js | 585 +++++++++++++++++++++++++++++++++++ process.cabal | 19 +- 6 files changed, 976 insertions(+), 22 deletions(-) create mode 100644 System/Process/JavaScript.hs create mode 100644 jsbits/process.js diff --git a/System/Process.hs b/System/Process.hs index dbacc149..c9616a8d 100644 --- 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 System.Process.Internals 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.Exit ( ExitCode(..) ) 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 @@ import System.IO.Error -- 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,7 +663,11 @@ getPid :: ProcessHandle -> IO (Maybe Pid) 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 @@ -672,7 +688,9 @@ getPid (ProcessHandle mh _ _) = do -- @since 1.6.12.0 getCurrentPid :: IO Pid getCurrentPid = -#ifdef WINDOWS +#if defined(javascript_HOST_ARCH) + getCurrentProcessId +#elif defined(WINDOWS) getCurrentProcessId #else getProcessID @@ -753,7 +771,11 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do 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 @@ -875,6 +897,26 @@ c_getProcessExitCode _ _ = ioError (ioeSetLocation unsupportedOperation "getProc c_waitForProcess :: PHANDLE -> Ptr CInt -> IO CInt c_waitForProcess _ _ = ioError (ioeSetLocation unsupportedOperation "waitForProcess") +#elif defined(javascript_HOST_ARCH) + +-- XXX descriptive argument names +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 foreign import ccall unsafe "terminateProcess" diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 18a2482d..61f2f1b7 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -57,6 +57,10 @@ import System.IO.Error 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.Win32.Types (HANDLE) 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 @@ type UserID = CGid #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,8 +93,8 @@ data CreateProcess = CreateProcess{ 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). -- -- @since 1.2.0.0 @@ -101,15 +106,15 @@ data CreateProcess = CreateProcess{ -- 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@ -- @@ -243,12 +248,17 @@ mbFd _ _std CreatePipe = return (-1) 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 index d48be8b8..97ac6841 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -45,9 +45,11 @@ module System.Process.Internals ( waitForJobCompletion, timeout_Infinite, #else +#if !defined(javascript_HOST_ARCH) pPrPr_disableITimers, c_execvpe, - ignoreSignal, defaultSignal, runInteractiveProcess_lock, +#endif + ignoreSignal, defaultSignal, #endif withFilePathException, withCEnvironment, translate, @@ -64,7 +66,9 @@ import System.Posix.Internals (FD) 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 diff --git a/System/Process/JavaScript.hs b/System/Process/JavaScript.hs new file mode 100644 index 00000000..5e89ed1f --- /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/jsbits/process.js b/jsbits/process.js new file mode 100644 index 00000000..f4049b63 --- /dev/null +++ b/jsbits/process.js @@ -0,0 +1,585 @@ +//#OPTIONS: CPP +// XXX do we need this? +#include "HsBaseConfig.h" + +// #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 index fe7564e1..c37b652c 100644 --- a/process.cabal +++ b/process.cabal @@ -64,13 +64,18 @@ library 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: From aa98ba72fc09a71c57f26be9232350ced93f6c0d Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Wed, 21 Jun 2023 00:03:24 +0900 Subject: [PATCH 2/5] remove some todos --- System/Process.hs | 1 - jsbits/process.js | 2 -- 2 files changed, 3 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index c9616a8d..18892893 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -899,7 +899,6 @@ c_waitForProcess _ _ = ioError (ioeSetLocation unsupportedOperation "waitForProc #elif defined(javascript_HOST_ARCH) --- XXX descriptive argument names foreign import javascript unsafe "h$process_terminateProcess" c_terminateProcess :: PHANDLE diff --git a/jsbits/process.js b/jsbits/process.js index f4049b63..77fca167 100644 --- a/jsbits/process.js +++ b/jsbits/process.js @@ -1,6 +1,4 @@ //#OPTIONS: CPP -// XXX do we need this? -#include "HsBaseConfig.h" // #define JS_TRACE_PROCESS 1 From f9235ef7bf9e1ab6fec485467aca0d104fa727c4 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 3 Jul 2023 13:16:25 +0900 Subject: [PATCH 3/5] remove js_broken from testsuite tests that now pass --- tests/all.T | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/tests/all.T b/tests/all.T index ab63f5d7..afc0bb1a 100644 --- a/tests/all.T +++ b/tests/all.T @@ -2,13 +2,13 @@ # in spurious error output changes. normalise_exec = normalise_fun(lambda s: s.replace('posix_spawnp', 'exec')) -test('process001', [js_broken(22349), req_process], compile_and_run, ['']) -test('process002', [fragile_for(16547, concurrent_ways), js_broken(22349), req_process], compile_and_run, ['']) -test('process003', [fragile_for(17245, concurrent_ways), js_broken(22349), req_process], compile_and_run, ['']) -test('process004', [normalise_exec, normalise_exe, js_broken(22349), req_process], compile_and_run, ['']) -test('T1780', [js_broken(22349), req_process], compile_and_run, ['']) -test('process005', [omit_ghci, js_broken(22349), req_process], compile_and_run, ['']) -test('process006', [js_broken(22349), req_process], compile_and_run, ['']) +test('process001', [req_process], compile_and_run, ['']) +test('process002', [fragile_for(16547, concurrent_ways), req_process], compile_and_run, ['']) +test('process003', [fragile_for(17245, concurrent_ways), req_process], compile_and_run, ['']) +test('process004', [normalise_exec, normalise_exe, req_process], compile_and_run, ['']) +test('T1780', [req_process], compile_and_run, ['']) +test('process005', [omit_ghci, req_process], compile_and_run, ['']) +test('process006', [req_process], compile_and_run, ['']) test('process007', [when(opsys('mingw32'), skip), @@ -16,7 +16,7 @@ test('process007', js_broken(22349), req_process], compile_and_run, ['']) -test('process008', [js_broken(22349), req_process], compile_and_run, ['']) +test('process008', [req_process], compile_and_run, ['']) # not the normal way: this test runs processes from multiple threads, and # will get stuck without the threaded RTS. @@ -37,18 +37,17 @@ test('T3994', [only_ways(['threaded1','threaded2']), pre_cmd('$MAKE -s --no-print-directory T3994app'), req_process], compile_and_run, ['']) -test('T4889',[js_broken(22349), req_process], compile_and_run, ['']) +test('T4889',[req_process], compile_and_run, ['']) -test('process009', [when(opsys('mingw32'), skip), js_broken(22349), req_process], compile_and_run, ['']) +test('process009', [when(opsys('mingw32'), skip), req_process], compile_and_run, ['']) test('process010', [ normalise_fun(lambda s: s.replace('illegal operation (Inappropriate ioctl for device)', 'does not exist (No such file or directory)')), normalise_exec, - js_broken(22349), req_process ], compile_and_run, ['']) test('process011', [when(opsys('mingw32'), skip), pre_cmd('{compiler} -no-hs-main -o process011_c process011_c.c'), js_broken(22349), req_process], compile_and_run, ['']) -test('T8343', [js_broken(22349), req_process], compile_and_run, ['']) -test('processT251', [js_broken(22349), omit_ghci, req_process], compile_and_run, ['']) +test('T8343', [req_process], compile_and_run, ['']) +test('processT251', [omit_ghci, req_process], compile_and_run, ['']) From 1db08dca3a0abac90e29693f6577a53d8057e9c0 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 3 Jul 2023 13:18:05 +0900 Subject: [PATCH 4/5] remove some stale todos --- jsbits/process.js | 2 -- 1 file changed, 2 deletions(-) diff --git a/jsbits/process.js b/jsbits/process.js index 77fca167..a511f34c 100644 --- a/jsbits/process.js +++ b/jsbits/process.js @@ -421,10 +421,8 @@ function h$process_commandToProcess(cmd, args) { h$setErrno('ENOENT'); return null; } - // XXX need to escape stuff return [com, " /c " + cmd]; } else { - // XXX need to escape stuff var r = [cmd]; r = r.concat(args); return r; From 56ebb5c916907a49e4215b0b7dee4677c77db478 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 4 Jul 2023 15:17:45 +0900 Subject: [PATCH 5/5] add some expected outputs for the GHC testsuite --- tests/process004.stdout-javascript-unknown-ghcjs | 2 ++ tests/process010.stdout-javascript-unknown-ghcjs | 4 ++++ 2 files changed, 6 insertions(+) create mode 100644 tests/process004.stdout-javascript-unknown-ghcjs create mode 100644 tests/process010.stdout-javascript-unknown-ghcjs diff --git a/tests/process004.stdout-javascript-unknown-ghcjs b/tests/process004.stdout-javascript-unknown-ghcjs new file mode 100644 index 00000000..e90c998d --- /dev/null +++ b/tests/process004.stdout-javascript-unknown-ghcjs @@ -0,0 +1,2 @@ +Exc: true: runInteractiveProcess: does not exist (No such file or directory) +Exc: true: runProcess: does not exist (No such file or directory) diff --git a/tests/process010.stdout-javascript-unknown-ghcjs b/tests/process010.stdout-javascript-unknown-ghcjs new file mode 100644 index 00000000..17d996a8 --- /dev/null +++ b/tests/process010.stdout-javascript-unknown-ghcjs @@ -0,0 +1,4 @@ +ExitSuccess +ExitFailure 1 +Exc: /non/existent: rawSystem: does not exist (No such file or directory) +Done