Merge pull request #292 from luite/js

Add support for the GHC JavaScript backend (node.js)

System/Process.hs

@@ -8,6 +8,10 @@
 
 #include <ghcplatform.h>
 
+#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,25 @@ c_getProcessExitCode _ _ = ioError (ioeSetLocation unsupportedOperation "getProc
 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
 
 foreign import ccall unsafe "terminateProcess"

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,16 +86,15 @@ 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
   env          :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)
   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

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