From 684ce185464e28acff2c5938f83274824db052f4 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 3 Dec 2016 10:12:08 +0000 Subject: [PATCH 01/29] GH77: Add scaffolding. --- System/Process/Windows.hsc | 77 ++++++++++++++++----- cbits/runProcess.c | 137 ++++++++++++++++++++++++++++++++++++- include/runProcess.h | 19 +++-- 3 files changed, 209 insertions(+), 24 deletions(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index c2582fed..6347dad2 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -3,6 +3,7 @@ module System.Process.Windows ( mkProcessHandle , translateInternal , createProcess_Internal + , createProcess_Internal_ext , withCEnvironment , closePHANDLE , startDelegateControlC @@ -53,6 +54,12 @@ mkProcessHandle h = do _ <- mkWeakMVar m (processHandleFinaliser m) return (ProcessHandle m False) +mkProcessHandle' :: PHANDLE -> IO (Maybe ProcessHandle) +mkProcessHandle' h = do + if h /= nullPtr + then return $ Just $ mkProcessHandle h + else return $ Nothing + processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = modifyMVar_ m $ \p_ -> do @@ -80,26 +87,40 @@ foreign import createProcess_Internal :: String -- ^ function name (for error messages) -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) - -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 = _ignored, - detach_console = mb_detach_console, - create_new_console = mb_create_new_console, - new_session = mb_new_session } + -> IO (Maybe Handle, Maybe Handle, + Maybe Handle, ProcessHandle) +createProcess_Internal fun cp + = let (hndStdInput, hndStdOutput, hndStdError, ph, _, _) = createProcess_Internal_ext fun cp + in return (hndStdInput, hndStdOutput, hndStdError, ph) + +createProcess_Internal_ext + :: String -- ^ function name (for error messages) + -> Bool -- ^ use job to manage process tree + -> CreateProcess + -> IO (Maybe Handle, Maybe Handle, + Maybe Handle, ProcessHandle, + Maybe ProcessHandle, Maybe ProcessHandle) + +createProcess_Internal fun useJob 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 = _ignored, + detach_console = mb_detach_console, + create_new_console = mb_create_new_console, + new_session = mb_new_session } = do (cmd, cmdline) <- commandToProcess cmdsp withFilePathException cmd $ alloca $ \ pfdStdInput -> alloca $ \ pfdStdOutput -> alloca $ \ pfdStdError -> + alloca $ \ hJob -> + alloca $ \ hIOcpPort -> maybeWith withCEnvironment mb_env $ \pEnv -> maybeWith withCWString mb_cwd $ \pWorkDir -> do withCWString cmdline $ \pcmdline -> do @@ -128,12 +149,17 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0) .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0) .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0)) + useJob + hJob + hIOcpPort hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode hndStdError <- mbPipe mb_stderr pfdStdError ReadMode - ph <- mkProcessHandle proc_handle + ph <- mkProcessHandle proc_handle + phJob <- mkProcessHandle' hJob + phIOCP <- mkProcessHandle' hIOcpPort return (hndStdInput, hndStdOutput, hndStdError, ph) {-# NOINLINE runInteractiveProcess_lock #-} @@ -155,6 +181,22 @@ stopDelegateControlC = return () -- End no-op functions +-- ---------------------------------------------------------------------------- +-- Interface to C bits + +foreign import ccall unsafe "terminateJob" + c_terminateJob + :: PHANDLE + -> IO CInt + +foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block + c_waitForJobCompletion + :: PHANDLE + :: PHANDLE + -> CInt + -> Ptr CInt + -> IO CInt + foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: CWString @@ -166,7 +208,10 @@ foreign import ccall unsafe "runInteractiveProcess" -> Ptr FD -> Ptr FD -> Ptr FD - -> CInt -- flags + -> CInt -- flags + -> Bool -- useJobObject + -> PHANDLE -- Handle to Job + -> PHANDLE -- Handle to I/O Completion Port -> IO PHANDLE commandToProcess diff --git a/cbits/runProcess.c b/cbits/runProcess.c index d6eae4a1..b8feecf8 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -510,12 +510,49 @@ mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, return TRUE; } +static HANDLE +createJob () +{ + HANDLE hJob = CreateJobObject (NULL, NULL); + JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli; + ZeroMemory(&jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)); + // Configure all child processes associated with the job to terminate when the + // Last process in the job terminates. This prevent half dead processes. + jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; + + return SetInformationJobObject(hJob, JobObjectExtendedLimitInformation, + &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)); +} + +static HANDLE +createCompletionPort (HANDLE hJob) +{ + HANDLE ioPort = CreateIoCompletionPort (INVALID_HANDLE_VALUE, NULL, 0, 1); + if (!ioPort) + { + // Something failed. Error is in GetLastError, let caller handler it. + return NULL; + } + + JOBOBJECT_ASSOCIATE_COMPLETION_PORT Port; + Port.CompletionKey = hJob; + Port.CompletionPort = ioPort; + if (!SetInformationJobObject(hJob, + JobObjectAssociateCompletionPortInformation, + &Port, sizeof(Port))) { + // Something failed. Error is in GetLastError, let caller handler it. + return NULL; + } + + return ioPort; +} + ProcHandle runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, wchar_t *environment, int fdStdIn, int fdStdOut, int fdStdErr, int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int flags) + int flags, bool useJobObject, HANDLE *hJob, HANDLE *hIOcpPort) { STARTUPINFO sInfo; PROCESS_INFORMATION pInfo; @@ -624,10 +661,41 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, dwFlags |= CREATE_NEW_CONSOLE; } + // If we're going to use a job object, then we have to create + // the thread suspended. + if (useJobObject) + { + dwFlags |= CREATE_SUSPENDED; + *hJob = createJob(); + if (!*hJob) + { + goto cleanup_err; + } + } + if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) { goto cleanup_err; } + + if (hJob) + { + // Create the completion port and attach it to the job + *hIOcpPort = createCompletionPort (*hJob); + if (!*hIOcpPort) + { + goto cleanup_err; + } + // Then associate the process and the job; + if (!AssignProcessToJobObject (*hJob, pInfo.hProcess)) + { + goto cleanup_err; + } + // And now that we've associated the new process with the job + // we can actively resume it. + ResumeThread (pInfo.hThread); + } + CloseHandle(pInfo.hThread); // Close the ends of the pipes that were inherited by the @@ -650,6 +718,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); + if (hJob ) CloseHandle(hJob); + if (hIOcpPort ) CloseHandle(hIOcpPort); maperrno(); return NULL; } @@ -657,7 +727,17 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, int terminateProcess (ProcHandle handle) { - if (!TerminateProcess((HANDLE) handle, 1)) { + if (!TerminateProcess ((HANDLE) handle, 1)) { + maperrno(); + return -1; + } + return 0; +} + +int +terminateJob (ProcHandle handle) +{ + if (!TerminateJobObject ((HANDLE)handle, 1)) { maperrno(); return -1; } @@ -702,4 +782,57 @@ waitForProcess (ProcHandle handle, int *pret) return -1; } +static int +waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) +{ + DWORD CompletionCode; + ULONG_PTR CompletionKey; + LPOVERLAPPED Overlapped; + *pExitCode = 0; + + // We have to loop here. It's a blocking call, but + // we get notified on each completion event. So if it's + // not one we care for we should just block again. + // If all processes are finished before this call is made + // then the initial call will return false. + // List of events we can listen to: + // https://msdn.microsoft.com/en-us/library/windows/desktop/ms684141(v=vs.85).aspx + while (GetQueuedCompletionStatus (ioPort, &CompletionCode, + &CompletionKey, &Overlapped, timeout)) { + + switch (CompletionCode) + { + case JOB_OBJECT_MSG_NEW_PROCESS: + // A new child process is born. + break; + case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS: + case JOB_OBJECT_MSG_EXIT_PROCESS: + // A child process has just exited. + // Read exit code, We assume the last process to exit + // is the process whose exit code we're interested in. + if (GetExitCodeProcess((HANDLE)Overlapped, (DWORD *)pExitCode) == 0) + { + maperrno(); + } + break; + case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO: + // All processes in the tree are done. + return 0; + default: + break; + } + } + + // Check to see if a timeout has occurred or that the + // all processes in the job were finished by the time we + // got to the loop. + if (Overlapped == NULL && (HANDLE)CompletionKey != hJob) + { + // Timeout occurred. + return -1; + } + + return 0; +} + #endif /* Win32 */ diff --git a/include/runProcess.h b/include/runProcess.h index d35e3e4f..1662a623 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -16,6 +16,7 @@ #define UNICODE #include #include +#include #endif #include @@ -53,14 +54,14 @@ typedef PHANDLE ProcHandle; #if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -extern ProcHandle runInteractiveProcess( char *const args[], - char *workingDirectory, - char **environment, +extern ProcHandle runInteractiveProcess( char *const args[], + char *workingDirectory, + char **environment, int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, - int *pfdStdOutput, + int *pfdStdInput, + int *pfdStdOutput, int *pfdStdError, gid_t *childGroup, uid_t *childUser, @@ -79,7 +80,13 @@ extern ProcHandle runInteractiveProcess( wchar_t *cmd, int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int flags); + int flags, + bool useJobObject, + HANDLE *hJob, + HANDLE *hIOcpPort ); + +extern int terminateJob( ProcHandle handle ); +extern int waitForJobCompletion( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode ); #endif From 80803096e76ee580bd255b5e9acc11ede2ed2690 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 08:15:39 +0000 Subject: [PATCH 02/29] GH77: Fixed compilation --- System/Process/Windows.hsc | 28 +++++++++++++++------------- cbits/runProcess.c | 12 +++++++++--- changelog.md | 1 + 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 6347dad2..c1294fa8 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE InterruptibleFFI #-} module System.Process.Windows ( mkProcessHandle , translateInternal @@ -57,7 +58,7 @@ mkProcessHandle h = do mkProcessHandle' :: PHANDLE -> IO (Maybe ProcessHandle) mkProcessHandle' h = do if h /= nullPtr - then return $ Just $ mkProcessHandle h + then Just <$> mkProcessHandle h else return $ Nothing processHandleFinaliser :: MVar ProcessHandle__ -> IO () @@ -90,8 +91,8 @@ createProcess_Internal -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess_Internal fun cp - = let (hndStdInput, hndStdOutput, hndStdError, ph, _, _) = createProcess_Internal_ext fun cp - in return (hndStdInput, hndStdOutput, hndStdError, ph) + = do (hndStdInput, hndStdOutput, hndStdError, ph, _, _) <- createProcess_Internal_ext fun False cp + return (hndStdInput, hndStdOutput, hndStdError, ph) createProcess_Internal_ext :: String -- ^ function name (for error messages) @@ -101,7 +102,7 @@ createProcess_Internal_ext Maybe Handle, ProcessHandle, Maybe ProcessHandle, Maybe ProcessHandle) -createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp, +createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env, std_in = mb_stdin, @@ -114,17 +115,18 @@ createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp, create_new_console = mb_create_new_console, new_session = mb_new_session } = do + let lenPtr = sizeOf (undefined :: WordPtr) (cmd, cmdline) <- commandToProcess cmdsp withFilePathException cmd $ - alloca $ \ pfdStdInput -> - alloca $ \ pfdStdOutput -> - alloca $ \ pfdStdError -> - alloca $ \ hJob -> - alloca $ \ hIOcpPort -> + alloca $ \ pfdStdInput -> + alloca $ \ pfdStdOutput -> + alloca $ \ pfdStdError -> + allocaBytes lenPtr $ \ hJob -> + allocaBytes lenPtr $ \ hIOcpPort -> maybeWith withCEnvironment mb_env $ \pEnv -> maybeWith withCWString mb_cwd $ \pWorkDir -> do withCWString cmdline $ \pcmdline -> do - + fdin <- mbFd fun fd_stdin mb_stdin fdout <- mbFd fun fd_stdout mb_stdout fderr <- mbFd fun fd_stderr mb_stderr @@ -160,7 +162,7 @@ createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp, ph <- mkProcessHandle proc_handle phJob <- mkProcessHandle' hJob phIOCP <- mkProcessHandle' hIOcpPort - return (hndStdInput, hndStdOutput, hndStdError, ph) + return (hndStdInput, hndStdOutput, hndStdError, ph, phJob, phIOCP) {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar () @@ -192,7 +194,7 @@ foreign import ccall unsafe "terminateJob" foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block c_waitForJobCompletion :: PHANDLE - :: PHANDLE + -> PHANDLE -> CInt -> Ptr CInt -> IO CInt diff --git a/cbits/runProcess.c b/cbits/runProcess.c index b8feecf8..b60bf077 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -520,8 +520,14 @@ createJob () // Last process in the job terminates. This prevent half dead processes. jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; - return SetInformationJobObject(hJob, JobObjectExtendedLimitInformation, - &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)); + if (SetInformationJobObject (hJob, JobObjectExtendedLimitInformation, + &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION))) + { + return hJob; + } + + maperrno(); + return NULL; } static HANDLE @@ -782,7 +788,7 @@ waitForProcess (ProcHandle handle, int *pret) return -1; } -static int +int waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) { DWORD CompletionCode; diff --git a/changelog.md b/changelog.md index 73c1814d..a8e77384 100644 --- a/changelog.md +++ b/changelog.md @@ -10,6 +10,7 @@ * New exposed `withCreateProcess` * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` +* Add support for monitoring process tree for termination with `...` ## 1.4.2.0 *January 2016* From d71248a3c94d28a4c52d59172c0a18385ccab3f8 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 10:44:19 +0000 Subject: [PATCH 03/29] GH77: Add terminate job --- System/Process/Windows.hsc | 51 +++++++++++++++++++++++++++++--------- 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index c1294fa8..5fc07dd6 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -14,6 +14,8 @@ module System.Process.Windows , createPipeInternal , createPipeInternalFd , interruptProcessGroupOfInternal + , terminateJob + , waitForJobCompletion ) where import System.Process.Common @@ -44,6 +46,14 @@ import System.Win32.Process (getProcessId) #include /* for _O_BINARY */ +##if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +##elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +##else +## error Unknown mingw32 arch +##endif + throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE throwErrnoIfBadPHandle = throwErrnoIfNull @@ -72,15 +82,7 @@ processHandleFinaliser m = closePHANDLE :: PHANDLE -> IO () closePHANDLE ph = c_CloseHandle ph -foreign import -#if defined(i386_HOST_ARCH) - stdcall -#elif defined(x86_64_HOST_ARCH) - ccall -#else -#error "Unknown architecture" -#endif - unsafe "CloseHandle" +foreign import WINDOWS_CCONV unsafe "CloseHandle" c_CloseHandle :: PHANDLE -> IO () @@ -183,13 +185,38 @@ stopDelegateControlC = return () -- End no-op functions + +-- ---------------------------------------------------------------------------- +-- Interface to C I/O CP bits + +terminateJob :: ProcessHandle -> CUInt -> IO Bool +terminateJob jh ecode = + withProcessHandle jh $ \p_ -> do + case p_ of + ClosedHandle _ -> return False + OpenHandle h -> c_terminateJobObject h ecode + +waitForJobCompletion :: ProcessHandle + -> ProcessHandle + -> CInt + -> IO (Maybe CInt) +waitForJobCompletion jh ioh timeout = + withProcessHandle jh $ \p_ -> + withProcessHandle ioh $ \io_ -> + case (p_, io_) of + (OpenHandle job, OpenHandle io) -> + alloca $ \p_exitCode -> Just <$> + c_waitForJobCompletion job io timeout p_exitCode + _ -> return Nothing + -- ---------------------------------------------------------------------------- -- Interface to C bits -foreign import ccall unsafe "terminateJob" - c_terminateJob +foreign import WINDOWS_CCONV unsafe "TerminateJobObject" + c_terminateJobObject :: PHANDLE - -> IO CInt + -> CUInt + -> IO Bool foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block c_waitForJobCompletion From 57e0c7f17823ccbc6d5aeacb3425c1d412163102 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 16:25:07 +0000 Subject: [PATCH 04/29] GH77: Update readme and export list. --- System/Process/Internals.hs | 3 +++ changelog.md | 3 ++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index af420093..fad7c929 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -34,6 +34,9 @@ module System.Process.Internals ( #ifndef WINDOWS pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, +#else + terminateJob, + waitForJobCompletion, #endif withFilePathException, withCEnvironment, translate, diff --git a/changelog.md b/changelog.md index a8e77384..3fd77f8e 100644 --- a/changelog.md +++ b/changelog.md @@ -10,7 +10,8 @@ * New exposed `withCreateProcess` * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` -* Add support for monitoring process tree for termination with `...` +* Add support for monitoring process tree for termination with `createProcess_Internal_ext` + , `terminateJob` and `waitForJobCompletion`. ## 1.4.2.0 *January 2016* From f6de6523e27c42ad8e92a375239dbfe8772e2b7e Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 17:20:45 +0000 Subject: [PATCH 05/29] GH77: Replaced system and rawSystem --- System/Process.hs | 25 ++++++++++++++++++++----- System/Process/Internals.hs | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 52 insertions(+), 6 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 0fc34454..44a43627 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -43,6 +43,7 @@ module System.Process ( readCreateProcessWithExitCode, readProcessWithExitCode, withCreateProcess, + executeAndWait, -- ** Related utilities showCommandForUser, @@ -852,9 +853,7 @@ when the process died as the result of a signal. -} system :: String -> IO ExitCode system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") -system str = do - (_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True } - waitForProcess p +system str = executeAndWait "system" (shell str) { delegate_ctlc = True } --TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} @@ -868,6 +867,22 @@ It will therefore behave more portably between operating systems than 'system'. The return codes and possible failures are the same as for 'system'. -} rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = do - (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } +rawSystem cmd args = executeAndWait "rawSystem" (proc cmd args) { delegate_ctlc = True } + +-- --------------------------------------------------------------------------- +-- executeAndWait + +-- | Create a new process and wait for it's termination. +-- +-- @since 1.4.?.? +executeAndWait :: String -> CreateProcess -> IO ExitCode +executeAndWait name proc_ = do +#if defined(WINDOWS) + (_,_,_,_,Just job,Just iocp) <- createProcessExt_ name True proc_ + maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp (-1) + where mkExitCode code | code == 0 = ExitSuccess + | otherwise = ExitFailure $ fromIntegral code +#else + (_,_,_,p) <- createProcess_ name proc_ waitForProcess p +#endif \ No newline at end of file diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index fad7c929..1ee8f5c4 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -43,6 +43,7 @@ module System.Process.Internals ( createPipe, createPipeFd, interruptProcessGroupOf, + createProcessExt_, ) where import Foreign.C @@ -60,7 +61,6 @@ import System.Process.Posix #endif -- ---------------------------------------------------------------------------- - -- | This function is almost identical to -- 'System.Process.createProcess'. The only differences are: -- @@ -81,6 +81,37 @@ createProcess_ createProcess_ = createProcess_Internal {-# INLINE createProcess_ #-} +-- ---------------------------------------------------------------------------- +-- | This function is almost identical to +-- 'createProcess_'. The only differences are: +-- +-- * A boolean argument can be given in order to create an I/O cp port to monitor +-- a process tree's progress on Windows. +-- +-- The function also returns two new handles: +-- * an I/O Completion Port handle on which events +-- will be signaled. +-- * a Job handle which can be used to kill all running +-- processes. +-- +-- On POSIX platforms these two new handles will always be Nothing +-- +-- @since 1.4.?.? +createProcessExt_ + :: String -- ^ function name (for error messages) + -> Bool -- ^ Use I/O CP port for monitoring + -> CreateProcess + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, + Maybe ProcessHandle, Maybe ProcessHandle) +#ifdef WINDOWS +createProcessExt_ = createProcess_Internal_ext +#else +createProcessExt_ name _ proc_ + = do (hndStdInput, hndStdOutput, hndStdError, ph) <- createProcess_ nme proc_ + return ((hndStdInput, hndStdOutput, hndStdError, ph, Nothing, Nothing) +#endif +{-# INLINE createProcessExt_ #-} + -- ------------------------------------------------------------------------ -- Escaping commands for shells From 3f440e22f658caed0ff42645610d84ff51dd3258 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 17:21:40 +0000 Subject: [PATCH 06/29] GH77: Updated readme --- changelog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 3fd77f8e..f5ab09a8 100644 --- a/changelog.md +++ b/changelog.md @@ -11,7 +11,7 @@ * New exposed `withCreateProcess` * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` * Add support for monitoring process tree for termination with `createProcess_Internal_ext` - , `terminateJob` and `waitForJobCompletion`. + , `terminateJob`, `waitForJobCompletion` and a new generic function `executeAndWait`. ## 1.4.2.0 *January 2016* From 86b273c670b78ed1913e9cc2b9a70641b0289f9c Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 18:45:26 +0000 Subject: [PATCH 07/29] GH77: Fix tests --- System/Process/Internals.hs | 2 +- System/Process/Windows.hsc | 2 +- cbits/runProcess.c | 8 +++++--- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 1ee8f5c4..c3dd4bde 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -106,7 +106,7 @@ createProcessExt_ #ifdef WINDOWS createProcessExt_ = createProcess_Internal_ext #else -createProcessExt_ name _ proc_ +createProcessExt_ name _ proc_ = do (hndStdInput, hndStdOutput, hndStdError, ph) <- createProcess_ nme proc_ return ((hndStdInput, hndStdOutput, hndStdError, ph, Nothing, Nothing) #endif diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 5fc07dd6..c0265122 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -128,7 +128,7 @@ createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, maybeWith withCEnvironment mb_env $ \pEnv -> maybeWith withCWString mb_cwd $ \pWorkDir -> do withCWString cmdline $ \pcmdline -> do - + fdin <- mbFd fun fd_stdin mb_stdin fdout <- mbFd fun fd_stdout mb_stdout fderr <- mbFd fun fd_stderr mb_stderr diff --git a/cbits/runProcess.c b/cbits/runProcess.c index b60bf077..6e6fcc12 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -671,6 +671,7 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, // the thread suspended. if (useJobObject) { + printf("** NO CALL\n"); dwFlags |= CREATE_SUSPENDED; *hJob = createJob(); if (!*hJob) @@ -684,8 +685,9 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, goto cleanup_err; } - if (hJob) + if (useJobObject && hJob) { + printf("** NO CALL\n"); // Create the completion port and attach it to the job *hIOcpPort = createCompletionPort (*hJob); if (!*hIOcpPort) @@ -724,8 +726,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); - if (hJob ) CloseHandle(hJob); - if (hIOcpPort ) CloseHandle(hIOcpPort); + if (useJobObject && hJob && *hJob ) CloseHandle(*hJob); + if (useJobObject && hIOcpPort && *hIOcpPort) CloseHandle(*hIOcpPort); maperrno(); return NULL; } From e7827bb4858130fbecae9abad04bb6f98e17ad2f Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 4 Dec 2016 20:03:27 +0000 Subject: [PATCH 08/29] GH77: Add failing test for Windows. --- tests/T9775/Makefile | 13 +++++++++++++ tests/T9775/T9775_fail.hs | 8 ++++++++ tests/T9775/all.T | 6 ++++++ tests/T9775/main.c | 6 ++++++ tests/T9775/ok.c | 6 ++++++ 5 files changed, 39 insertions(+) create mode 100644 tests/T9775/Makefile create mode 100644 tests/T9775/T9775_fail.hs create mode 100644 tests/T9775/all.T create mode 100644 tests/T9775/main.c create mode 100644 tests/T9775/ok.c diff --git a/tests/T9775/Makefile b/tests/T9775/Makefile new file mode 100644 index 00000000..65191d5a --- /dev/null +++ b/tests/T9775/Makefile @@ -0,0 +1,13 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T12725 +T12725: + '$(TEST_CC)' ok.c -o ok.exe + '$(TEST_CC)' main.c -o main.exe + diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs new file mode 100644 index 00000000..8aaca8c9 --- /dev/null +++ b/tests/T9775/T9775_fail.hs @@ -0,0 +1,8 @@ +module Main where + +import System.Process + +main + = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" "") + waitForProcess p >> print + \ No newline at end of file diff --git a/tests/T9775/all.T b/tests/T9775/all.T new file mode 100644 index 00000000..dbccb29b --- /dev/null +++ b/tests/T9775/all.T @@ -0,0 +1,6 @@ + +test('T12725_fail', + [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), + [unless(opsys('mingw32'),skip)] + pre_cmd('$MAKE -s --no-print-directory T12725')], + compile_and_run, ['']) diff --git a/tests/T9775/main.c b/tests/T9775/main.c new file mode 100644 index 00000000..cc27edb3 --- /dev/null +++ b/tests/T9775/main.c @@ -0,0 +1,6 @@ +#include + +int main(int argc, char *argv[]) { + char * args[2] = { "ok", NULL }; + execv("./ok", args); +} diff --git a/tests/T9775/ok.c b/tests/T9775/ok.c new file mode 100644 index 00000000..dcd08c4a --- /dev/null +++ b/tests/T9775/ok.c @@ -0,0 +1,6 @@ +#include + +int main() { + printf("ok\n"); + return 0; +} From 3bf217f1170975205d571a5de3680d9616675319 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 10 Dec 2016 20:34:30 +0000 Subject: [PATCH 09/29] GH77: Working --- System/Process/Windows.hsc | 18 ++++++++++-------- cbits/runProcess.c | 34 +++++++++++++++++++++------------- tests/T9775/T9775_fail.hs | 4 ++-- tests/T9775/T9775_good.hs | 12 ++++++++++++ tests/T9775/ok.c | 6 ++++-- 5 files changed, 49 insertions(+), 25 deletions(-) create mode 100644 tests/T9775/T9775_good.hs diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index c0265122..cb40a3ea 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -162,8 +162,8 @@ createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, hndStdError <- mbPipe mb_stderr pfdStdError ReadMode ph <- mkProcessHandle proc_handle - phJob <- mkProcessHandle' hJob - phIOCP <- mkProcessHandle' hIOcpPort + phJob <- mkProcessHandle' =<< peek hJob + phIOCP <- mkProcessHandle' =<< peek hIOcpPort return (hndStdInput, hndStdOutput, hndStdError, ph, phJob, phIOCP) {-# NOINLINE runInteractiveProcess_lock #-} @@ -198,15 +198,17 @@ terminateJob jh ecode = waitForJobCompletion :: ProcessHandle -> ProcessHandle - -> CInt + -> CUInt -> IO (Maybe CInt) waitForJobCompletion jh ioh timeout = withProcessHandle jh $ \p_ -> withProcessHandle ioh $ \io_ -> case (p_, io_) of (OpenHandle job, OpenHandle io) -> - alloca $ \p_exitCode -> Just <$> - c_waitForJobCompletion job io timeout p_exitCode + alloca $ \p_exitCode -> do ret <- c_waitForJobCompletion job io timeout p_exitCode + if ret == 0 + then Just <$> peek p_exitCode + else return Nothing _ -> return Nothing -- ---------------------------------------------------------------------------- @@ -222,7 +224,7 @@ foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can bloc c_waitForJobCompletion :: PHANDLE -> PHANDLE - -> CInt + -> CUInt -> Ptr CInt -> IO CInt @@ -239,8 +241,8 @@ foreign import ccall unsafe "runInteractiveProcess" -> Ptr FD -> CInt -- flags -> Bool -- useJobObject - -> PHANDLE -- Handle to Job - -> PHANDLE -- Handle to I/O Completion Port + -> Ptr PHANDLE -- Handle to Job + -> Ptr PHANDLE -- Handle to I/O Completion Port -> IO PHANDLE commandToProcess diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 6e6fcc12..cb87dc83 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -518,7 +518,7 @@ createJob () ZeroMemory(&jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)); // Configure all child processes associated with the job to terminate when the // Last process in the job terminates. This prevent half dead processes. - jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; + //jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; if (SetInformationJobObject (hJob, JobObjectExtendedLimitInformation, &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION))) @@ -577,6 +577,7 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, ZeroMemory(&sInfo, sizeof(sInfo)); sInfo.cb = sizeof(sInfo); sInfo.dwFlags = STARTF_USESTDHANDLES; + ZeroMemory(&pInfo, sizeof(pInfo)); if (fdStdIn == -1) { if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) @@ -671,13 +672,19 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, // the thread suspended. if (useJobObject) { - printf("** NO CALL\n"); dwFlags |= CREATE_SUSPENDED; *hJob = createJob(); if (!*hJob) { goto cleanup_err; } + + // Create the completion port and attach it to the job + *hIOcpPort = createCompletionPort(*hJob); + if (!*hIOcpPort) + { + goto cleanup_err; + } } if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) @@ -685,20 +692,14 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, goto cleanup_err; } - if (useJobObject && hJob) + if (useJobObject && hJob && *hJob) { - printf("** NO CALL\n"); - // Create the completion port and attach it to the job - *hIOcpPort = createCompletionPort (*hJob); - if (!*hIOcpPort) - { - goto cleanup_err; - } // Then associate the process and the job; if (!AssignProcessToJobObject (*hJob, pInfo.hProcess)) { goto cleanup_err; } + // And now that we've associated the new process with the job // we can actively resume it. ResumeThread (pInfo.hThread); @@ -728,6 +729,7 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); if (useJobObject && hJob && *hJob ) CloseHandle(*hJob); if (useJobObject && hIOcpPort && *hIOcpPort) CloseHandle(*hIOcpPort); + maperrno(); return NULL; } @@ -796,7 +798,8 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) DWORD CompletionCode; ULONG_PTR CompletionKey; LPOVERLAPPED Overlapped; - *pExitCode = 0; + *pExitCode = 5; + HANDLE lastProc; // We have to loop here. It's a blocking call, but // we get notified on each completion event. So if it's @@ -812,17 +815,22 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) { case JOB_OBJECT_MSG_NEW_PROCESS: // A new child process is born. + lastProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, (DWORD)(uintptr_t)Overlapped); break; case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS: case JOB_OBJECT_MSG_EXIT_PROCESS: + { // A child process has just exited. // Read exit code, We assume the last process to exit // is the process whose exit code we're interested in. - if (GetExitCodeProcess((HANDLE)Overlapped, (DWORD *)pExitCode) == 0) + if (GetExitCodeProcess (lastProc, (DWORD *)pExitCode) == 0) { maperrno(); + return -1; } - break; + printf("Exit(0x%x): %d\n", (HANDLE)Overlapped, *pExitCode); + } + break; case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO: // All processes in the tree are done. return 0; diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs index 8aaca8c9..28d38f33 100644 --- a/tests/T9775/T9775_fail.hs +++ b/tests/T9775/T9775_fail.hs @@ -3,6 +3,6 @@ module Main where import System.Process main - = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" "") - waitForProcess p >> print + = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" []) + waitForProcess p >>= print \ No newline at end of file diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs new file mode 100644 index 00000000..48b73764 --- /dev/null +++ b/tests/T9775/T9775_good.hs @@ -0,0 +1,12 @@ +module Main where + +import System.Process +import System.Process.Internals +import System.Exit + +main + = do (_,_,_,_,Just j,Just io) <- createProcessExt_ "T9775_good" True (proc "main" []) + maybe (ExitFailure (-7)) mkExitCode <$> waitForJobCompletion j io 0xFFFFFFFF >>= print + where mkExitCode code | code == 0 = ExitSuccess + | otherwise = ExitFailure $ fromIntegral code + \ No newline at end of file diff --git a/tests/T9775/ok.c b/tests/T9775/ok.c index dcd08c4a..71ef3bd2 100644 --- a/tests/T9775/ok.c +++ b/tests/T9775/ok.c @@ -1,6 +1,8 @@ #include +#include int main() { - printf("ok\n"); - return 0; + Sleep(2000); + printf("bye bye\n"); + return 120; } From 282aa2e3a4893da8b685d86c8bdb498350010843 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 10 Dec 2016 21:35:31 +0000 Subject: [PATCH 10/29] GH77: Finish implementation. --- System/Process.hs | 2 +- System/Process/Internals.hs | 1 + System/Process/Windows.hsc | 4 ++++ cbits/runProcess.c | 10 ++++------ tests/T9775/T9775_fail.hs | 14 +++++++------- tests/T9775/T9775_good.hs | 22 +++++++++++----------- 6 files changed, 28 insertions(+), 25 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 44a43627..aa868f46 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -879,7 +879,7 @@ executeAndWait :: String -> CreateProcess -> IO ExitCode executeAndWait name proc_ = do #if defined(WINDOWS) (_,_,_,_,Just job,Just iocp) <- createProcessExt_ name True proc_ - maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp (-1) + maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp timeout_Infinite where mkExitCode code | code == 0 = ExitSuccess | otherwise = ExitFailure $ fromIntegral code #else diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index c3dd4bde..29e348d4 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -37,6 +37,7 @@ module System.Process.Internals ( #else terminateJob, waitForJobCompletion, + timeout_Infinite, #endif withFilePathException, withCEnvironment, translate, diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index cb40a3ea..c28ff07a 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -16,6 +16,7 @@ module System.Process.Windows , interruptProcessGroupOfInternal , terminateJob , waitForJobCompletion + , timeout_Infinite ) where import System.Process.Common @@ -196,6 +197,9 @@ terminateJob jh ecode = ClosedHandle _ -> return False OpenHandle h -> c_terminateJobObject h ecode +timeout_Infinite :: CUInt +timeout_Infinite = 0xFFFFFFFF + waitForJobCompletion :: ProcessHandle -> ProcessHandle -> CUInt diff --git a/cbits/runProcess.c b/cbits/runProcess.c index cb87dc83..43e3d7a6 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -798,8 +798,7 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) DWORD CompletionCode; ULONG_PTR CompletionKey; LPOVERLAPPED Overlapped; - *pExitCode = 5; - HANDLE lastProc; + *pExitCode = 0; // We have to loop here. It's a blocking call, but // we get notified on each completion event. So if it's @@ -815,7 +814,6 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) { case JOB_OBJECT_MSG_NEW_PROCESS: // A new child process is born. - lastProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, (DWORD)(uintptr_t)Overlapped); break; case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS: case JOB_OBJECT_MSG_EXIT_PROCESS: @@ -823,12 +821,12 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) // A child process has just exited. // Read exit code, We assume the last process to exit // is the process whose exit code we're interested in. - if (GetExitCodeProcess (lastProc, (DWORD *)pExitCode) == 0) + HANDLE pHwnd = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, (DWORD)(uintptr_t)Overlapped); + if (GetExitCodeProcess(pHwnd, (DWORD *)pExitCode) == 0) { maperrno(); - return -1; + return 1; } - printf("Exit(0x%x): %d\n", (HANDLE)Overlapped, *pExitCode); } break; case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO: diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs index 28d38f33..b9095b1c 100644 --- a/tests/T9775/T9775_fail.hs +++ b/tests/T9775/T9775_fail.hs @@ -1,8 +1,8 @@ -module Main where - -import System.Process - -main - = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" []) - waitForProcess p >>= print +module Main where + +import System.Process + +main + = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" []) + waitForProcess p >>= print \ No newline at end of file diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs index 48b73764..07600e5e 100644 --- a/tests/T9775/T9775_good.hs +++ b/tests/T9775/T9775_good.hs @@ -1,12 +1,12 @@ -module Main where - -import System.Process -import System.Process.Internals -import System.Exit - -main - = do (_,_,_,_,Just j,Just io) <- createProcessExt_ "T9775_good" True (proc "main" []) - maybe (ExitFailure (-7)) mkExitCode <$> waitForJobCompletion j io 0xFFFFFFFF >>= print - where mkExitCode code | code == 0 = ExitSuccess - | otherwise = ExitFailure $ fromIntegral code +module Main where + +import System.Process +import System.Process.Internals +import System.Exit + +main + = do (_,_,_,_,Just j,Just io) <- createProcessExt_ "T9775_good" True (proc "main" []) + maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion j io timeout_Infinite >>= print + where mkExitCode code | code == 0 = ExitSuccess + | otherwise = ExitFailure $ fromIntegral code \ No newline at end of file From e89d6e1362e77c8d2da57d991327d99b6b51b06a Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 10 Dec 2016 21:56:58 +0000 Subject: [PATCH 11/29] GH77: Update testsuite. --- tests/T9775/T9775_fail.hs | 1 - tests/T9775/T9775_good.hs | 1 - tests/T9775/all.T | 6 ++++++ 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs index b9095b1c..a3e239e2 100644 --- a/tests/T9775/T9775_fail.hs +++ b/tests/T9775/T9775_fail.hs @@ -5,4 +5,3 @@ import System.Process main = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" []) waitForProcess p >>= print - \ No newline at end of file diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs index 07600e5e..94617541 100644 --- a/tests/T9775/T9775_good.hs +++ b/tests/T9775/T9775_good.hs @@ -9,4 +9,3 @@ main maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion j io timeout_Infinite >>= print where mkExitCode code | code == 0 = ExitSuccess | otherwise = ExitFailure $ fromIntegral code - \ No newline at end of file diff --git a/tests/T9775/all.T b/tests/T9775/all.T index dbccb29b..f8d77647 100644 --- a/tests/T9775/all.T +++ b/tests/T9775/all.T @@ -4,3 +4,9 @@ test('T12725_fail', [unless(opsys('mingw32'),skip)] pre_cmd('$MAKE -s --no-print-directory T12725')], compile_and_run, ['']) + +test('T12725_good', + [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), + [unless(opsys('mingw32'),skip)] + pre_cmd('$MAKE -s --no-print-directory T12725')], + compile_and_run, ['']) From 2e3542d060088d2a518286c498d69ac24b3df77a Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 11 Dec 2016 00:07:08 +0000 Subject: [PATCH 12/29] GH77: update tests. --- tests/T9775/Makefile | 4 ++-- tests/T9775/all.T | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/T9775/Makefile b/tests/T9775/Makefile index 65191d5a..6eafccf1 100644 --- a/tests/T9775/Makefile +++ b/tests/T9775/Makefile @@ -6,8 +6,8 @@ TOP=../../../testsuite include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -.PHONY: T12725 -T12725: +.PHONY: T9775 +T9775: '$(TEST_CC)' ok.c -o ok.exe '$(TEST_CC)' main.c -o main.exe diff --git a/tests/T9775/all.T b/tests/T9775/all.T index f8d77647..694c0c87 100644 --- a/tests/T9775/all.T +++ b/tests/T9775/all.T @@ -1,12 +1,12 @@ -test('T12725_fail', +test('T9775_fail', [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), - [unless(opsys('mingw32'),skip)] - pre_cmd('$MAKE -s --no-print-directory T12725')], + [unless(opsys('mingw32'),skip)], + pre_cmd('$MAKE -s --no-print-directory T9775')], compile_and_run, ['']) -test('T12725_good', +test('T9775_good', [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), - [unless(opsys('mingw32'),skip)] - pre_cmd('$MAKE -s --no-print-directory T12725')], + [unless(opsys('mingw32'),skip)], + pre_cmd('$MAKE -s --no-print-directory T9775')], compile_and_run, ['']) From eb85aacbd1f58655ae74c920b1b3208f8ce7ba94 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 11 Dec 2016 12:01:03 +0000 Subject: [PATCH 13/29] GH77: fix tests --- tests/T9775/Makefile | 2 +- tests/T9775/all.T | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/T9775/Makefile b/tests/T9775/Makefile index 6eafccf1..f5a54bcc 100644 --- a/tests/T9775/Makefile +++ b/tests/T9775/Makefile @@ -2,7 +2,7 @@ # assumes the package is part of a GHC build tree with the testsuite # installed in ../../../testsuite. -TOP=../../../testsuite +TOP=../../../../testsuite include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk diff --git a/tests/T9775/all.T b/tests/T9775/all.T index 694c0c87..55e77508 100644 --- a/tests/T9775/all.T +++ b/tests/T9775/all.T @@ -1,12 +1,14 @@ test('T9775_fail', [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), - [unless(opsys('mingw32'),skip)], + extra_files(['ok.c', 'main.c']), + unless(opsys('mingw32'),skip), pre_cmd('$MAKE -s --no-print-directory T9775')], - compile_and_run, ['']) + compile_and_run, ['']) test('T9775_good', [extra_clean(['ok.o', 'ok.exe', 'main.o', 'main.exe']), - [unless(opsys('mingw32'),skip)], + unless(opsys('mingw32'),skip), + extra_files(['ok.c', 'main.c']), pre_cmd('$MAKE -s --no-print-directory T9775')], - compile_and_run, ['']) + compile_and_run, ['']) From 605ce3e53e0e7672e76a4c890c39bc48d8dca39d Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 11 Dec 2016 15:23:19 +0000 Subject: [PATCH 14/29] GH77: Accept output. --- tests/T9775/T9775_fail.stdout | 2 ++ tests/T9775/T9775_good.stdout | 2 ++ 2 files changed, 4 insertions(+) create mode 100644 tests/T9775/T9775_fail.stdout create mode 100644 tests/T9775/T9775_good.stdout diff --git a/tests/T9775/T9775_fail.stdout b/tests/T9775/T9775_fail.stdout new file mode 100644 index 00000000..7374c53f --- /dev/null +++ b/tests/T9775/T9775_fail.stdout @@ -0,0 +1,2 @@ +ExitSuccess +bye bye diff --git a/tests/T9775/T9775_good.stdout b/tests/T9775/T9775_good.stdout new file mode 100644 index 00000000..e08b3555 --- /dev/null +++ b/tests/T9775/T9775_good.stdout @@ -0,0 +1,2 @@ +bye bye +ExitFailure 120 From 3a5935ce6353e5c9e35214a070c31342098e5c6c Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Mon, 2 Jan 2017 15:54:07 +0000 Subject: [PATCH 15/29] GH77: rewrote implementation. --- System/Process.hs | 76 +++++++++++++++------------------ System/Process/Common.hs | 25 ++++++++++- System/Process/Internals.hs | 57 ++++++++++--------------- System/Process/Posix.hs | 10 ++++- System/Process/Windows.hsc | 84 ++++++++++++++++--------------------- 5 files changed, 122 insertions(+), 130 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index aa868f46..f9db2d0a 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -43,7 +43,6 @@ module System.Process ( readCreateProcessWithExitCode, readProcessWithExitCode, withCreateProcess, - executeAndWait, -- ** Related utilities showCommandForUser, @@ -116,7 +115,8 @@ proc cmd args = CreateProcess { cmdspec = RawCommand cmd args, create_new_console = False, new_session = False, child_group = Nothing, - child_user = Nothing } + child_user = Nothing, + use_process_jobs = False } -- | Construct a 'CreateProcess' record for passing to 'createProcess', -- representing a command to be passed to the shell. @@ -134,7 +134,8 @@ shell str = CreateProcess { cmdspec = ShellCommand str, create_new_console = False, new_session = False, child_group = Nothing, - child_user = Nothing } + child_user = Nothing, + use_process_jobs = False } {- | This is the most general way to spawn an external process. The @@ -191,7 +192,7 @@ createProcess cp = do maybeCloseStd (std_in cp) maybeCloseStd (std_out cp) maybeCloseStd (std_err cp) - return r + return $ unwrapHandles r where maybeCloseStd :: StdStream -> IO () maybeCloseStd (UseHandle hdl) @@ -229,7 +230,7 @@ withCreateProcess_ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a withCreateProcess_ fun c action = - C.bracketOnError (createProcess_ fun c) cleanupProcess + C.bracketOnError (unwrapHandles <$> createProcess_ fun c) cleanupProcess (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) @@ -268,18 +269,16 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, -- -- @since 1.2.0.0 spawnProcess :: FilePath -> [String] -> IO ProcessHandle -spawnProcess cmd args = do - (_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args) - return p +spawnProcess cmd args = + procHandle <$> createProcess_ "spawnProcess" (proc cmd args) -- | Creates a new process to run the specified shell command. -- It does not wait for the program to finish, but returns the 'ProcessHandle'. -- -- @since 1.2.0.0 spawnCommand :: String -> IO ProcessHandle -spawnCommand cmd = do - (_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd) - return p +spawnCommand cmd = + procHandle <$> createProcess_ "spawnCommand" (shell cmd) -- ---------------------------------------------------------------------------- @@ -595,8 +594,9 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) modifyProcessHandle ph $ \p_' -> case p_' of - ClosedHandle e -> return (p_',e) - OpenHandle ph' -> do + ClosedHandle e -> return (p_',e) + OpenExtHandle{} -> error "waitForProcess handle mismatch." + OpenHandle ph' -> do closePHANDLE ph' code <- peek pret let e = if (code == 0) @@ -606,6 +606,10 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do when delegating_ctlc $ endDelegateControlC e return e + OpenExtHandle _ job iocp -> do + maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp timeout_Infinite + where mkExitCode code | code == 0 = ExitSuccess + | otherwise = ExitFailure $ fromIntegral code -- ---------------------------------------------------------------------------- @@ -625,7 +629,8 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do (m_e, was_open) <- modifyProcessHandle ph $ \p_ -> case p_ of ClosedHandle e -> return (p_, (Just e, False)) - OpenHandle h -> + open -> do + let h = getHandle open alloca $ \pExitCode -> do res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ c_getProcessExitCode h pExitCode @@ -641,6 +646,10 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do Just e | was_open && delegating_ctlc -> endDelegateControlC e _ -> return () return m_e + where getHandle :: ProcessHandle__ -> PHANDLE + getHandle (OpenHandle h) = h + getHandle (ClosedHandle _) = error "getHandle: handle closed." + getHandle (OpenExtHandle h _ _) = h -- ---------------------------------------------------------------------------- @@ -665,8 +674,9 @@ terminateProcess :: ProcessHandle -> IO () terminateProcess ph = do withProcessHandle ph $ \p_ -> case p_ of - ClosedHandle _ -> return () - OpenHandle h -> do + ClosedHandle _ -> return () + OpenExtHandle{} -> terminateJob ph 1 >> return () + OpenHandle h -> do throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h return () -- does not close the handle, we might want to try terminating it @@ -715,9 +725,8 @@ runCommand :: String -> IO ProcessHandle -runCommand string = do - (_,_,_,ph) <- createProcess_ "runCommand" (shell string) - return ph +runCommand string = + procHandle <$> createProcess_ "runCommand" (shell string) -- ---------------------------------------------------------------------------- @@ -747,8 +756,7 @@ runProcess -> IO ProcessHandle runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do - (_,_,_,ph) <- - createProcess_ "runProcess" + r <- createProcess_ "runProcess" (proc cmd args){ cwd = mb_cwd, env = mb_env, std_in = mbToStd mb_stdin, @@ -757,7 +765,7 @@ runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do maybeClose mb_stdin maybeClose mb_stdout maybeClose mb_stderr - return ph + return $ procHandle r where maybeClose :: Maybe Handle -> IO () maybeClose (Just hdl) @@ -816,7 +824,7 @@ runInteractiveProcess1 -> IO (Handle,Handle,Handle,ProcessHandle) runInteractiveProcess1 fun cmd = do (mb_in, mb_out, mb_err, p) <- - createProcess_ fun + unwrapHandles <$> createProcess_ fun cmd{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } @@ -853,7 +861,7 @@ when the process died as the result of a signal. -} system :: String -> IO ExitCode system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") -system str = executeAndWait "system" (shell str) { delegate_ctlc = True } +system str = procHandle <$> createProcess_ "system" (shell str) { delegate_ctlc = True } >>= waitForProcess --TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} @@ -867,22 +875,4 @@ It will therefore behave more portably between operating systems than 'system'. The return codes and possible failures are the same as for 'system'. -} rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = executeAndWait "rawSystem" (proc cmd args) { delegate_ctlc = True } - --- --------------------------------------------------------------------------- --- executeAndWait - --- | Create a new process and wait for it's termination. --- --- @since 1.4.?.? -executeAndWait :: String -> CreateProcess -> IO ExitCode -executeAndWait name proc_ = do -#if defined(WINDOWS) - (_,_,_,_,Just job,Just iocp) <- createProcessExt_ name True proc_ - maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp timeout_Infinite - where mkExitCode code | code == 0 = ExitSuccess - | otherwise = ExitFailure $ fromIntegral code -#else - (_,_,_,p) <- createProcess_ name proc_ - waitForProcess p -#endif \ No newline at end of file +rawSystem cmd args = procHandle <$> createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } >>= waitForProcess diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 4b18eb82..0f70f7a3 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -6,6 +6,7 @@ module System.Process.Common , StdStream (..) , ProcessHandle(..) , ProcessHandle__(..) + , ProcRetHandles (..) , withFilePathException , PHANDLE , modifyProcessHandle @@ -94,13 +95,27 @@ data CreateProcess = CreateProcess{ -- 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; does nothing on other platforms. -- -- Default: @Nothing@ -- -- @since 1.4.0.0 + use_process_jobs :: Bool -- ^ On Windows systems this flag indicates that we should wait for the entire process tree + -- to finish before unblocking. On POSIX system this flag is ignored. + -- + -- Default: @False@ + -- + -- @since 1.x.x.x } deriving (Show, Eq) +-- | contains the handles returned by a call to createProcess_Internal +data ProcRetHandles + = ProcRetHandles { hStdInput :: Maybe Handle + , hStdOutput :: Maybe Handle + , hStdError :: Maybe Handle + , procHandle :: ProcessHandle + } + data CmdSpec = ShellCommand String -- ^ A command line to execute using the shell @@ -154,8 +169,14 @@ data StdStream None of the process-creation functions in this library wait for termination: they all return a 'ProcessHandle' which may be used to wait for the process later. + + On Windows a second wait method can be used to block for event + completion. This requires two handles. A process job handle and + a events handle to monitor. -} -data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode +data ProcessHandle__ = OpenHandle PHANDLE + | OpenExtHandle PHANDLE PHANDLE PHANDLE + | ClosedHandle ExitCode data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool withFilePathException :: FilePath -> IO a -> IO a diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 29e348d4..99196c92 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -24,13 +24,14 @@ module System.Process.Internals ( PHANDLE, closePHANDLE, mkProcessHandle, modifyProcessHandle, withProcessHandle, CreateProcess(..), - CmdSpec(..), StdStream(..), + CmdSpec(..), StdStream(..), ProcRetHandles (..), createProcess_, runGenProcess_, --deprecated fdToHandle, startDelegateControlC, endDelegateControlC, stopDelegateControlC, + unwrapHandles, #ifndef WINDOWS pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, @@ -44,7 +45,6 @@ module System.Process.Internals ( createPipe, createPipeFd, interruptProcessGroupOf, - createProcessExt_, ) where import Foreign.C @@ -70,24 +70,8 @@ import System.Process.Posix -- * This function takes an extra @String@ argument to be used in creating -- error messages. -- --- This function has been available from the "System.Process.Internals" module --- for some time, and is part of the "System.Process" module since version --- 1.2.1.0. --- --- @since 1.2.1.0 -createProcess_ - :: String -- ^ function name (for error messages) - -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess_ = createProcess_Internal -{-# INLINE createProcess_ #-} - --- ---------------------------------------------------------------------------- --- | This function is almost identical to --- 'createProcess_'. The only differences are: --- --- * A boolean argument can be given in order to create an I/O cp port to monitor --- a process tree's progress on Windows. +-- * 'use_process_jobs' can set in CreateProcess since 1.4.?.? in order to create +-- an I/O completion port to monitor a process tree's progress on Windows. -- -- The function also returns two new handles: -- * an I/O Completion Port handle on which events @@ -97,21 +81,18 @@ createProcess_ = createProcess_Internal -- -- On POSIX platforms these two new handles will always be Nothing -- --- @since 1.4.?.? -createProcessExt_ - :: String -- ^ function name (for error messages) - -> Bool -- ^ Use I/O CP port for monitoring +-- +-- This function has been available from the "System.Process.Internals" module +-- for some time, and is part of the "System.Process" module since version +-- 1.2.1.0. +-- +-- @since 1.2.1.0 +createProcess_ + :: String -- ^ function name (for error messages) -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, - Maybe ProcessHandle, Maybe ProcessHandle) -#ifdef WINDOWS -createProcessExt_ = createProcess_Internal_ext -#else -createProcessExt_ name _ proc_ - = do (hndStdInput, hndStdOutput, hndStdError, ph) <- createProcess_ nme proc_ - return ((hndStdInput, hndStdOutput, hndStdError, ph, Nothing, Nothing) -#endif -{-# INLINE createProcessExt_ #-} + -> IO ProcRetHandles +createProcess_ = createProcess_Internal +{-# INLINE createProcess_ #-} -- ------------------------------------------------------------------------ -- Escaping commands for shells @@ -172,6 +153,10 @@ translate :: String -> String translate = translateInternal {-# INLINE translate #-} +-- --------------------------------------------------------------------------- +-- unwrapHandles +unwrapHandles :: ProcRetHandles -> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +unwrapHandles r = (hStdInput r, hStdOutput r, hStdError r, procHandle r) -- ---------------------------------------------------------------------------- -- Deprecated / compat @@ -186,8 +171,8 @@ runGenProcess_ -> 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 + = unwrapHandles <$> createProcess_ fun c { delegate_ctlc = True } +runGenProcess_ fun c _ _ = unwrapHandles <$> createProcess_ fun c -- --------------------------------------------------------------------------- -- createPipe diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index d11e793c..8b921650 100644 --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -100,7 +100,7 @@ withCEnvironment envir act = createProcess_Internal :: String -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + -> IO ProcRetHandles createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, @@ -166,7 +166,13 @@ createProcess_Internal fun hndStdError <- mbPipe mb_stderr pfdStdError ReadMode ph <- mkProcessHandle proc_handle mb_delegate_ctlc - return (hndStdInput, hndStdOutput, hndStdError, ph) + return ProcRetHandles { hStdInput = hndStdInput + , hStdOutput = hndStdOutput + , hStdError = hndStdError + , procHandle = ph + , procJobHandle = Nothing + , procPortHandle = Nothing + } {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar () diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index c28ff07a..b9c4eae0 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -4,7 +4,6 @@ module System.Process.Windows ( mkProcessHandle , translateInternal , createProcess_Internal - , createProcess_Internal_ext , withCEnvironment , closePHANDLE , startDelegateControlC @@ -60,23 +59,22 @@ throwErrnoIfBadPHandle = throwErrnoIfNull -- On Windows, we have to close this HANDLE when it is no longer required, -- hence we add a finalizer to it -mkProcessHandle :: PHANDLE -> IO ProcessHandle -mkProcessHandle h = do - m <- newMVar (OpenHandle h) +mkProcessHandle :: PHANDLE -> PHANDLE -> PHANDLE -> IO ProcessHandle +mkProcessHandle h job io = do + m <- if job == nullPtr && io == nullPtr + then newMVar (OpenHandle h) + else newMVar (OpenExtHandle h job io) _ <- mkWeakMVar m (processHandleFinaliser m) return (ProcessHandle m False) -mkProcessHandle' :: PHANDLE -> IO (Maybe ProcessHandle) -mkProcessHandle' h = do - if h /= nullPtr - then Just <$> mkProcessHandle h - else return $ Nothing - processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = modifyMVar_ m $ \p_ -> do case p_ of - OpenHandle ph -> closePHANDLE ph + OpenHandle ph -> closePHANDLE ph + OpenExtHandle ph job io -> closePHANDLE ph + >> closePHANDLE job + >> closePHANDLE io _ -> return () return (error "closed process handle") @@ -91,21 +89,9 @@ foreign import WINDOWS_CCONV unsafe "CloseHandle" createProcess_Internal :: String -- ^ function name (for error messages) -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, - Maybe Handle, ProcessHandle) -createProcess_Internal fun cp - = do (hndStdInput, hndStdOutput, hndStdError, ph, _, _) <- createProcess_Internal_ext fun False cp - return (hndStdInput, hndStdOutput, hndStdError, ph) - -createProcess_Internal_ext - :: String -- ^ function name (for error messages) - -> Bool -- ^ use job to manage process tree - -> CreateProcess - -> IO (Maybe Handle, Maybe Handle, - Maybe Handle, ProcessHandle, - Maybe ProcessHandle, Maybe ProcessHandle) + -> IO ProcRetHandles -createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, +createProcess_Internal fun CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env, std_in = mb_stdin, @@ -116,7 +102,8 @@ createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, delegate_ctlc = _ignored, detach_console = mb_detach_console, create_new_console = mb_create_new_console, - new_session = mb_new_session } + new_session = mb_new_session, + use_process_jobs = use_job } = do let lenPtr = sizeOf (undefined :: WordPtr) (cmd, cmdline) <- commandToProcess cmdsp @@ -154,7 +141,7 @@ createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, .|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0) .|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0) .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0)) - useJob + use_job hJob hIOcpPort @@ -162,10 +149,14 @@ createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp, hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode hndStdError <- mbPipe mb_stderr pfdStdError ReadMode - ph <- mkProcessHandle proc_handle - phJob <- mkProcessHandle' =<< peek hJob - phIOCP <- mkProcessHandle' =<< peek hIOcpPort - return (hndStdInput, hndStdOutput, hndStdError, ph, phJob, phIOCP) + phJob <- peek hJob + phIOCP <- peek hIOcpPort + ph <- mkProcessHandle proc_handle phJob phIOCP + return ProcRetHandles { hStdInput = hndStdInput + , hStdOutput = hndStdOutput + , hStdError = hndStdError + , procHandle = ph + } {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar () @@ -194,26 +185,22 @@ terminateJob :: ProcessHandle -> CUInt -> IO Bool terminateJob jh ecode = withProcessHandle jh $ \p_ -> do case p_ of - ClosedHandle _ -> return False - OpenHandle h -> c_terminateJobObject h ecode + ClosedHandle _ -> return False + OpenHandle _ -> return False + OpenExtHandle _ job _ -> c_terminateJobObject job ecode timeout_Infinite :: CUInt timeout_Infinite = 0xFFFFFFFF -waitForJobCompletion :: ProcessHandle - -> ProcessHandle +waitForJobCompletion :: PHANDLE + -> PHANDLE -> CUInt -> IO (Maybe CInt) -waitForJobCompletion jh ioh timeout = - withProcessHandle jh $ \p_ -> - withProcessHandle ioh $ \io_ -> - case (p_, io_) of - (OpenHandle job, OpenHandle io) -> +waitForJobCompletion job io timeout = alloca $ \p_exitCode -> do ret <- c_waitForJobCompletion job io timeout p_exitCode if ret == 0 then Just <$> peek p_exitCode else return Nothing - _ -> return Nothing -- ---------------------------------------------------------------------------- -- Interface to C bits @@ -355,15 +342,18 @@ interruptProcessGroupOfInternal ph = do withProcessHandle ph $ \p_ -> do case p_ of ClosedHandle _ -> return () - OpenHandle h -> do + _ -> do let h = case p_ of + OpenHandle x -> x + OpenExtHandle x _ _ -> x + _ -> error "interruptProcessGroupOfInternal" #if mingw32_HOST_OS - pid <- getProcessId h - generateConsoleCtrlEvent cTRL_BREAK_EVENT pid + pid <- getProcessId h + generateConsoleCtrlEvent cTRL_BREAK_EVENT pid -- We can't use an #elif here, because MIN_VERSION_unix isn't defined -- on Windows, so on Windows cpp fails: -- error: missing binary operator before token "(" #else - pgid <- getProcessGroupIDOf h - signalProcessGroup sigINT pgid + pgid <- getProcessGroupIDOf h + signalProcessGroup sigINT pgid #endif - return () + return () From ae57e8c22b4e7f8356b1f21744add5b2f4d462b1 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Mon, 2 Jan 2017 20:30:50 +0000 Subject: [PATCH 16/29] GH77: fix compile errors. --- System/Process/Windows.hsc | 29 +++++++++++++++++++++++++---- cbits/runProcess.c | 15 ++++++++++++--- include/runProcess.h | 5 ++++- tests/T9775/T9775_good.hs | 8 ++------ 4 files changed, 43 insertions(+), 14 deletions(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index b9c4eae0..ff8d3a79 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -22,6 +22,7 @@ import System.Process.Common import Control.Concurrent import Control.Exception import Data.Bits +import Data.Maybe import Foreign.C import Foreign.Marshal import Foreign.Ptr @@ -197,14 +198,32 @@ waitForJobCompletion :: PHANDLE -> CUInt -> IO (Maybe CInt) waitForJobCompletion job io timeout = - alloca $ \p_exitCode -> do ret <- c_waitForJobCompletion job io timeout p_exitCode - if ret == 0 - then Just <$> peek p_exitCode - else return Nothing + alloca $ \p_exitCode -> do + items <- newMVar $ [] + setter <- mkSetter (insertItem items) + getter <- mkGetter (getItem items) + ret <- c_waitForJobCompletion job io timeout p_exitCode setter getter + if ret == 0 + then Just <$> peek p_exitCode + else return Nothing + +insertItem :: Eq k => MVar [(k, v)] -> k -> v -> IO () +insertItem env_ k v = modifyMVar_ env_ (return . ((k, v):)) + +getItem :: Eq k => MVar [(k, v)] -> k -> IO v +getItem env_ k = withMVar env_ (\m -> return $ fromJust $ lookup k m) -- ---------------------------------------------------------------------------- -- Interface to C bits +type SetterDef = CUInt -> Ptr () -> IO () +type GetterDef = CUInt -> IO (Ptr ()) + +foreign import ccall "wrapper" + mkSetter :: SetterDef -> IO (FunPtr SetterDef) +foreign import ccall "wrapper" + mkGetter :: GetterDef -> IO (FunPtr GetterDef) + foreign import WINDOWS_CCONV unsafe "TerminateJobObject" c_terminateJobObject :: PHANDLE @@ -217,6 +236,8 @@ foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can bloc -> PHANDLE -> CUInt -> Ptr CInt + -> FunPtr (SetterDef) + -> FunPtr (GetterDef) -> IO CInt foreign import ccall unsafe "runInteractiveProcess" diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 43e3d7a6..17463d67 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -792,8 +792,9 @@ waitForProcess (ProcHandle handle, int *pret) return -1; } + int -waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) +waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get ) { DWORD CompletionCode; ULONG_PTR CompletionKey; @@ -813,15 +814,23 @@ waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode) switch (CompletionCode) { case JOB_OBJECT_MSG_NEW_PROCESS: + { // A new child process is born. - break; + // Retrieve and save the process handle from the process id. + // We'll need it for later but we can't retrieve it after the + // process has exited. + DWORD pid = (DWORD)(uintptr_t)Overlapped; + HANDLE pHwnd = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, pid); + set(pid, pHwnd); + } + break; case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS: case JOB_OBJECT_MSG_EXIT_PROCESS: { // A child process has just exited. // Read exit code, We assume the last process to exit // is the process whose exit code we're interested in. - HANDLE pHwnd = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, TRUE, (DWORD)(uintptr_t)Overlapped); + HANDLE pHwnd = get((DWORD)(uintptr_t)Overlapped); if (GetExitCodeProcess(pHwnd, (DWORD *)pExitCode) == 0) { maperrno(); diff --git a/include/runProcess.h b/include/runProcess.h index 1662a623..38073894 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -85,8 +85,11 @@ extern ProcHandle runInteractiveProcess( wchar_t *cmd, HANDLE *hJob, HANDLE *hIOcpPort ); +typedef void(*setterDef)(DWORD, HANDLE); +typedef HANDLE(*getterDef)(DWORD); + extern int terminateJob( ProcHandle handle ); -extern int waitForJobCompletion( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode ); +extern int waitForJobCompletion( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get ); #endif diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs index 94617541..6634ad37 100644 --- a/tests/T9775/T9775_good.hs +++ b/tests/T9775/T9775_good.hs @@ -1,11 +1,7 @@ module Main where import System.Process -import System.Process.Internals -import System.Exit main - = do (_,_,_,_,Just j,Just io) <- createProcessExt_ "T9775_good" True (proc "main" []) - maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion j io timeout_Infinite >>= print - where mkExitCode code | code == 0 = ExitSuccess - | otherwise = ExitFailure $ fromIntegral code + = do (_,_,_,p) <- createProcess_ "T9775_good" (proc "main" []{ use_process_jobs = True }) + waitForProcess p >>= print From 7ef688e2e716b309ad70926d3ce79791def57e4f Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Thu, 5 Jan 2017 19:53:40 +0000 Subject: [PATCH 17/29] GH77: Update readme. --- changelog.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.md b/changelog.md index f5ab09a8..991be99e 100644 --- a/changelog.md +++ b/changelog.md @@ -10,8 +10,8 @@ * New exposed `withCreateProcess` * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` -* Add support for monitoring process tree for termination with `createProcess_Internal_ext` - , `terminateJob`, `waitForJobCompletion` and a new generic function `executeAndWait`. +* Add support for monitoring process tree for termination with the parameter `use_process_jobs` + in `CreateProcess` on Windows. Also added a function `terminateJob` to kill entire process tree. ## 1.4.2.0 *January 2016* From c3c067be022d192a7599476afd3bed903070b4a1 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 7 Jan 2017 11:51:44 +0000 Subject: [PATCH 18/29] GH77: restored compatibility. --- System/Process.hs | 34 +++++++++++++++++++++------------- System/Process/Internals.hs | 8 ++++---- process.cabal | 2 +- tests/T9775/T9775_fail.hs | 2 +- tests/T9775/T9775_good.hs | 2 +- 5 files changed, 28 insertions(+), 20 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index f9db2d0a..245ad8b6 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -192,7 +192,7 @@ createProcess cp = do maybeCloseStd (std_in cp) maybeCloseStd (std_out cp) maybeCloseStd (std_err cp) - return $ unwrapHandles r + return r where maybeCloseStd :: StdStream -> IO () maybeCloseStd (UseHandle hdl) @@ -230,7 +230,7 @@ withCreateProcess_ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a withCreateProcess_ fun c action = - C.bracketOnError (unwrapHandles <$> createProcess_ fun c) cleanupProcess + C.bracketOnError (createProcess_ fun c) cleanupProcess (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) @@ -269,16 +269,18 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, -- -- @since 1.2.0.0 spawnProcess :: FilePath -> [String] -> IO ProcessHandle -spawnProcess cmd args = - procHandle <$> createProcess_ "spawnProcess" (proc cmd args) +spawnProcess cmd args = do + (_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args) + return p -- | Creates a new process to run the specified shell command. -- It does not wait for the program to finish, but returns the 'ProcessHandle'. -- -- @since 1.2.0.0 spawnCommand :: String -> IO ProcessHandle -spawnCommand cmd = - procHandle <$> createProcess_ "spawnCommand" (shell cmd) +spawnCommand cmd = do + (_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd) + return p -- ---------------------------------------------------------------------------- @@ -725,8 +727,9 @@ runCommand :: String -> IO ProcessHandle -runCommand string = - procHandle <$> createProcess_ "runCommand" (shell string) +runCommand string = do + (_,_,_,ph) <- createProcess_ "runCommand" (shell string) + return ph -- ---------------------------------------------------------------------------- @@ -756,7 +759,8 @@ runProcess -> IO ProcessHandle runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do - r <- createProcess_ "runProcess" + (_,_,_,ph) <- + createProcess_ "runProcess" (proc cmd args){ cwd = mb_cwd, env = mb_env, std_in = mbToStd mb_stdin, @@ -765,7 +769,7 @@ runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do maybeClose mb_stdin maybeClose mb_stdout maybeClose mb_stderr - return $ procHandle r + return ph where maybeClose :: Maybe Handle -> IO () maybeClose (Just hdl) @@ -824,7 +828,7 @@ runInteractiveProcess1 -> IO (Handle,Handle,Handle,ProcessHandle) runInteractiveProcess1 fun cmd = do (mb_in, mb_out, mb_err, p) <- - unwrapHandles <$> createProcess_ fun + createProcess_ fun cmd{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } @@ -861,7 +865,9 @@ when the process died as the result of a signal. -} system :: String -> IO ExitCode system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") -system str = procHandle <$> createProcess_ "system" (shell str) { delegate_ctlc = True } >>= waitForProcess +system str = do + (_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True } + waitForProcess p --TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} @@ -875,4 +881,6 @@ It will therefore behave more portably between operating systems than 'system'. The return codes and possible failures are the same as for 'system'. -} rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = procHandle <$> createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } >>= waitForProcess +rawSystem cmd args = do + (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } + waitForProcess p diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 99196c92..299f8342 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -90,8 +90,8 @@ import System.Process.Posix createProcess_ :: String -- ^ function name (for error messages) -> CreateProcess - -> IO ProcRetHandles -createProcess_ = createProcess_Internal + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess_ msg proc_ = unwrapHandles <$> createProcess_Internal msg proc_ {-# INLINE createProcess_ #-} -- ------------------------------------------------------------------------ @@ -171,8 +171,8 @@ runGenProcess_ -> 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' - = unwrapHandles <$> createProcess_ fun c { delegate_ctlc = True } -runGenProcess_ fun c _ _ = unwrapHandles <$> createProcess_ fun c + = createProcess_ fun c { delegate_ctlc = True } +runGenProcess_ fun c _ _ = createProcess_ fun c -- --------------------------------------------------------------------------- -- createPipe diff --git a/process.cabal b/process.cabal index 6734c253..b3399385 100644 --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.4.3.0 +version: 1.4.3.1 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE diff --git a/tests/T9775/T9775_fail.hs b/tests/T9775/T9775_fail.hs index a3e239e2..b2cc020d 100644 --- a/tests/T9775/T9775_fail.hs +++ b/tests/T9775/T9775_fail.hs @@ -3,5 +3,5 @@ module Main where import System.Process main - = do (_,_,_,p) <- createProcess_ "T9775_fail" (proc "main" []) + = do (_,_,_,p) <- createProcess (proc "main" []) waitForProcess p >>= print diff --git a/tests/T9775/T9775_good.hs b/tests/T9775/T9775_good.hs index 6634ad37..a66c3165 100644 --- a/tests/T9775/T9775_good.hs +++ b/tests/T9775/T9775_good.hs @@ -3,5 +3,5 @@ module Main where import System.Process main - = do (_,_,_,p) <- createProcess_ "T9775_good" (proc "main" []{ use_process_jobs = True }) + = do (_,_,_,p) <- createProcess ((proc "main" []){ use_process_jobs = True }) waitForProcess p >>= print From 5a12fa4a4c19245d7273c2d025223ca3fb619c2b Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 7 Jan 2017 15:01:00 +0000 Subject: [PATCH 19/29] GH77: rebased. --- cbits/runProcess.c | 2 +- tests/T9775/main.c | 12 ++++++------ tests/T9775/ok.c | 16 ++++++++-------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 17463d67..7ba6a49a 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -518,7 +518,7 @@ createJob () ZeroMemory(&jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)); // Configure all child processes associated with the job to terminate when the // Last process in the job terminates. This prevent half dead processes. - //jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; + jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; if (SetInformationJobObject (hJob, JobObjectExtendedLimitInformation, &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION))) diff --git a/tests/T9775/main.c b/tests/T9775/main.c index cc27edb3..2c891b1a 100644 --- a/tests/T9775/main.c +++ b/tests/T9775/main.c @@ -1,6 +1,6 @@ -#include - -int main(int argc, char *argv[]) { - char * args[2] = { "ok", NULL }; - execv("./ok", args); -} +#include + +int main(int argc, char *argv[]) { + char * args[2] = { "ok", NULL }; + execv("./ok", args); +} diff --git a/tests/T9775/ok.c b/tests/T9775/ok.c index 71ef3bd2..50191dc0 100644 --- a/tests/T9775/ok.c +++ b/tests/T9775/ok.c @@ -1,8 +1,8 @@ -#include -#include - -int main() { - Sleep(2000); - printf("bye bye\n"); - return 120; -} +#include +#include + +int main() { + Sleep(2000); + printf("bye bye\n"); + return 120; +} From e41616e249ea56de4321d4b9227c985a3522798f Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 8 Jan 2017 00:34:19 +0000 Subject: [PATCH 20/29] GH77: fix Posix. --- System/Process/Posix.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index 8b921650..201c4e9e 100644 --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -169,9 +169,7 @@ createProcess_Internal fun return ProcRetHandles { hStdInput = hndStdInput , hStdOutput = hndStdOutput , hStdError = hndStdError - , procHandle = ph - , procJobHandle = Nothing - , procPortHandle = Nothing + , procHandle = ph] } {-# NOINLINE runInteractiveProcess_lock #-} From 5a0d7bcdb353e283eea7daaeb0517d2164cb8041 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 8 Jan 2017 06:36:04 +0000 Subject: [PATCH 21/29] GH77: remove typo. --- System/Process/Posix.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index 201c4e9e..dbcd2858 100644 --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -169,7 +169,7 @@ createProcess_Internal fun return ProcRetHandles { hStdInput = hndStdInput , hStdOutput = hndStdOutput , hStdError = hndStdError - , procHandle = ph] + , procHandle = ph } {-# NOINLINE runInteractiveProcess_lock #-} From ad967f819ad001ce54f6ef367165f4b8c143fbb4 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 8 Jan 2017 09:51:18 +0000 Subject: [PATCH 22/29] GH77: fix pattern matching posix. --- System/Process/Posix.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index dbcd2858..cd8573f4 100644 --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -295,7 +295,8 @@ interruptProcessGroupOfInternal interruptProcessGroupOfInternal ph = do withProcessHandle ph $ \p_ -> do case p_ of - ClosedHandle _ -> return () - OpenHandle h -> do + OpenExtHandle{} -> return () + ClosedHandle _ -> return () + OpenHandle h -> do pgid <- getProcessGroupIDOf h signalProcessGroup sigINT pgid From 2d6933b5afeb6e8c468b74d25c071e0afb779f38 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 8 Jan 2017 09:52:35 +0000 Subject: [PATCH 23/29] GH77: replace <$> with fmap --- System/Process/Internals.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 299f8342..026cd998 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -91,7 +91,7 @@ createProcess_ :: String -- ^ function name (for error messages) -> CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess_ msg proc_ = unwrapHandles <$> createProcess_Internal msg proc_ +createProcess_ msg proc_ = unwrapHandles `fmap` createProcess_Internal msg proc_ {-# INLINE createProcess_ #-} -- ------------------------------------------------------------------------ From 4a423ad28582d7e0a68b184f6c5eed8a25fa29ef Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 8 Jan 2017 11:29:18 +0000 Subject: [PATCH 24/29] GH77: Add appropriate ifdefs. --- System/Process.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 245ad8b6..a0574e40 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -609,10 +609,13 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do endDelegateControlC e return e OpenExtHandle _ job iocp -> do - maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp timeout_Infinite +#if defined(WINDOWS) + maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite where mkExitCode code | code == 0 = ExitSuccess | otherwise = ExitFailure $ fromIntegral code - +#else + error "OpenExtHandle should not happen on POSIX." +#endif -- ---------------------------------------------------------------------------- -- getProcessExitCode @@ -677,7 +680,11 @@ terminateProcess ph = do withProcessHandle ph $ \p_ -> case p_ of ClosedHandle _ -> return () +#if defined(WINDOWS) OpenExtHandle{} -> terminateJob ph 1 >> return () +#else + OpenExtHandle{} -> error "terminateProcess with OpenExtHandle should not happen on POSIX." +#endif OpenHandle h -> do throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h return () From 94a2140511345df3aab8185fa338bbde03421926 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Mon, 16 Jan 2017 02:39:13 +0000 Subject: [PATCH 25/29] GH77: fixed bug. --- cbits/runProcess.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 7ba6a49a..d6c26cc5 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -685,6 +685,9 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, { goto cleanup_err; } + } else { + *hJob = NULL; + *hIOcpPort = NULL; } if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) From 523b3ddc54e81fdfb7bf1aab32f03e387ca972d1 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Tue, 17 Jan 2017 19:02:39 +0000 Subject: [PATCH 26/29] GH77: Added note.' --- cbits/runProcess.c | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index d6c26cc5..ae184c82 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -553,6 +553,38 @@ createCompletionPort (HANDLE hJob) return ioPort; } +/* Note [Windows exec interaction] + + The basic issue that process jobs tried to solve is this: + + Say you have two programs A and B. Now A calls B. There are two ways to do this. + + 1) You can use the normal CreateProcess API, which is what normal Windows code do. + Using this approach, the current waitForProcess works absolutely fine. + 2) You can call the emulated POSIX function _exec, which of course is supposed to + allow the child process to replace the parent. + + With approach 2) waitForProcess falls apart because the Win32's process model does + not allow this the same way as linux. _exec is emulated by first making a call to + CreateProcess to spawn B and then immediately exiting from A. So you have two + different processes. + + waitForProcess is waiting on the termination of A. Because A is immediately killed, + waitForProcess will return even though B is still running. This is why for instance + the GHC testsuite on Windows had lots of file locked errors. + + This approach creates a new Job and assigned A to the job, but also all future + processes spawned by A. This allows us to listen in on events, such as, when all + processes in the job are finished, but also allows us to propagate exit codes from + _exec calls. + + The only reason we need this at all is because we don't interact with just actual + native code on Windows, and instead have a lot of ported POSIX code. + + The Job handle is returned to the user because Jobs have additional benefits as well, + such as allowing you to specify resource limits on the to be spawned process. + */ + ProcHandle runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, wchar_t *environment, @@ -668,8 +700,9 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, dwFlags |= CREATE_NEW_CONSOLE; } - // If we're going to use a job object, then we have to create - // the thread suspended. + /* If we're going to use a job object, then we have to create + the thread suspended. + See Note [Windows exec interaction]. */ if (useJobObject) { dwFlags |= CREATE_SUSPENDED; From 0f7b9483a11a51bd8f2941f590f22b5f91fb1df7 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 29 Jan 2017 20:52:53 +0000 Subject: [PATCH 27/29] Updated based on review --- System/Process.hs | 24 ++++++++++++------------ System/Process/Common.hs | 4 ++-- System/Process/Internals.hs | 10 +++++----- System/Process/Windows.hsc | 9 +-------- changelog.md | 4 ++-- process.cabal | 2 +- 6 files changed, 23 insertions(+), 30 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index a0574e40..53c1f21d 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -596,8 +596,8 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) modifyProcessHandle ph $ \p_' -> case p_' of - ClosedHandle e -> return (p_',e) - OpenExtHandle{} -> error "waitForProcess handle mismatch." + ClosedHandle e -> return (p_', e) + OpenExtHandle{} -> return (p_', ExitFailure (-1)) OpenHandle ph' -> do closePHANDLE ph' code <- peek pret @@ -608,13 +608,13 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do when delegating_ctlc $ endDelegateControlC e return e - OpenExtHandle _ job iocp -> do + OpenExtHandle _ job iocp -> #if defined(WINDOWS) maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite where mkExitCode code | code == 0 = ExitSuccess | otherwise = ExitFailure $ fromIntegral code #else - error "OpenExtHandle should not happen on POSIX." + return $ ExitFailure (-1) #endif -- ---------------------------------------------------------------------------- @@ -635,14 +635,14 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do case p_ of ClosedHandle e -> return (p_, (Just e, False)) open -> do - let h = getHandle open alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ - c_getProcessExitCode h pExitCode - code <- peek pExitCode + res <- let getCode h = throwErrnoIfMinus1Retry "getProcessExitCode" $ + c_getProcessExitCode h pExitCode + in maybe (return 0) getCode $ getHandle open if res == 0 then return (p_, (Nothing, False)) else do + code <- peek pExitCode closePHANDLE h let e | code == 0 = ExitSuccess | otherwise = ExitFailure (fromIntegral code) @@ -651,10 +651,10 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do Just e | was_open && delegating_ctlc -> endDelegateControlC e _ -> return () return m_e - where getHandle :: ProcessHandle__ -> PHANDLE - getHandle (OpenHandle h) = h - getHandle (ClosedHandle _) = error "getHandle: handle closed." - getHandle (OpenExtHandle h _ _) = h + where getHandle :: ProcessHandle__ -> Maybe PHANDLE + getHandle (OpenHandle h) = Just h + getHandle (ClosedHandle _) = Nothing + getHandle (OpenExtHandle h _ _) = Just h -- ---------------------------------------------------------------------------- diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 0f70f7a3..b2caae66 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -101,11 +101,11 @@ data CreateProcess = CreateProcess{ -- -- @since 1.4.0.0 use_process_jobs :: Bool -- ^ On Windows systems this flag indicates that we should wait for the entire process tree - -- to finish before unblocking. On POSIX system this flag is ignored. + -- to finish before unblocking. On POSIX systems this flag is ignored. -- -- Default: @False@ -- - -- @since 1.x.x.x + -- @since 1.5.0.0 } deriving (Show, Eq) -- | contains the handles returned by a call to createProcess_Internal diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 026cd998..036e1c07 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -32,13 +32,13 @@ module System.Process.Internals ( endDelegateControlC, stopDelegateControlC, unwrapHandles, -#ifndef WINDOWS - pPrPr_disableITimers, c_execvpe, - ignoreSignal, defaultSignal, -#else +#ifdef WINDOWS terminateJob, waitForJobCompletion, timeout_Infinite, +#else + pPrPr_disableITimers, c_execvpe, + ignoreSignal, defaultSignal, #endif withFilePathException, withCEnvironment, translate, @@ -70,7 +70,7 @@ import System.Process.Posix -- * This function takes an extra @String@ argument to be used in creating -- error messages. -- --- * 'use_process_jobs' can set in CreateProcess since 1.4.?.? in order to create +-- * 'use_process_jobs' can be set in CreateProcess since 1.5.0.0 in order to create -- an I/O completion port to monitor a process tree's progress on Windows. -- -- The function also returns two new handles: diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index ff8d3a79..07c4f0df 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -44,17 +44,10 @@ import System.Win32.Process (getProcessId) -- The double hash is used so that hsc does not process this include file ##include "processFlags.h" +#include "windows_cconv.h" #include /* for _O_BINARY */ -##if defined(i386_HOST_ARCH) -## define WINDOWS_CCONV stdcall -##elif defined(x86_64_HOST_ARCH) -## define WINDOWS_CCONV ccall -##else -## error Unknown mingw32 arch -##endif - throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE throwErrnoIfBadPHandle = throwErrnoIfNull diff --git a/changelog.md b/changelog.md index 991be99e..bee88743 100644 --- a/changelog.md +++ b/changelog.md @@ -5,13 +5,13 @@ * Bug fix: Don't close already closed pipes [#81](https://github.com/haskell/process/pull/81) * Relax version bounds of Win32 to allow 2.5. +* Add support for monitoring process tree for termination with the parameter `use_process_jobs` + in `CreateProcess` on Windows. Also added a function `terminateJob` to kill entire process tree. ## 1.4.3.0 *December 2016* * New exposed `withCreateProcess` * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream` -* Add support for monitoring process tree for termination with the parameter `use_process_jobs` - in `CreateProcess` on Windows. Also added a function `terminateJob` to kill entire process tree. ## 1.4.2.0 *January 2016* diff --git a/process.cabal b/process.cabal index b3399385..0ef5b914 100644 --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.4.3.1 +version: 1.5.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE From f8b53d8db973ecabaeaf5ae5b1332734fccf1419 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 29 Jan 2017 21:06:58 +0000 Subject: [PATCH 28/29] rebased and set back WINDOWS_CCONV --- System/Process/Windows.hsc | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 07c4f0df..ff8d3a79 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -44,10 +44,17 @@ import System.Win32.Process (getProcessId) -- The double hash is used so that hsc does not process this include file ##include "processFlags.h" -#include "windows_cconv.h" #include /* for _O_BINARY */ +##if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +##elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +##else +## error Unknown mingw32 arch +##endif + throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE throwErrnoIfBadPHandle = throwErrnoIfNull From 9bcbaeb7bd53d10087ebedd53b1d87efac814aac Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sun, 29 Jan 2017 21:48:24 +0000 Subject: [PATCH 29/29] fix build. --- System/Process.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 53c1f21d..81a5788c 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -636,17 +636,19 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do ClosedHandle e -> return (p_, (Just e, False)) open -> do alloca $ \pExitCode -> do - res <- let getCode h = throwErrnoIfMinus1Retry "getProcessExitCode" $ - c_getProcessExitCode h pExitCode - in maybe (return 0) getCode $ getHandle open - if res == 0 - then return (p_, (Nothing, False)) - else do - code <- peek pExitCode - closePHANDLE h - let e | code == 0 = ExitSuccess - | otherwise = ExitFailure (fromIntegral code) - return (ClosedHandle e, (Just e, True)) + case getHandle open of + Nothing -> return (p_, (Nothing, False)) + Just h -> do + res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ + c_getProcessExitCode h pExitCode + code <- peek pExitCode + if res == 0 + then return (p_, (Nothing, False)) + else do + closePHANDLE h + let e | code == 0 = ExitSuccess + | otherwise = ExitFailure (fromIntegral code) + return (ClosedHandle e, (Just e, True)) case m_e of Just e | was_open && delegating_ctlc -> endDelegateControlC e _ -> return ()