Unverified Commit 97116f3d authored by Michael Snoyman's avatar Michael Snoyman Committed by GitHub

Merge pull request #168 from bgamari/fix-jobs

Fix job support
parents b8fea1f6 fcdb254e
......@@ -54,12 +54,14 @@ module System.Process (
-- $ctlc-handling
-- * Process completion
-- ** Notes about @exec@ on Windows
-- $exec-on-windows
waitForProcess,
getProcessExitCode,
terminateProcess,
interruptProcessGroupOf,
-- Interprocess communication
-- * Interprocess communication
createPipe,
createPipeFd,
......@@ -394,6 +396,32 @@ processFailedException fun cmd args exit_code =
-- For even more detail on this topic, see
-- <http://www.cons.org/cracauer/sigint.html "Proper handling of SIGINT/SIGQUIT">.
-- $exec-on-windows
--
-- Note that processes which use the POSIX @exec@ system call (e.g. @gcc@)
-- require special care on Windows. Specifically, the @msvcrt@ C runtime used
-- frequently on Windows emulates @exec@ in a non-POSIX compliant manner, where
-- the caller will be terminated (with exit code 0) and execution will continue
-- in a new process. As a result, on Windows it will appear as though a child
-- process which has called @exec@ has terminated despite the fact that the
-- process would still be running on a POSIX-compliant platform.
--
-- Since many programs do use @exec@, the @process@ library exposes the
-- 'use_process_jobs' flag to make it possible to reliably detect when such a
-- process completes. When this flag is set a 'ProcessHandle' will not be
-- deemed to be \"finished\" until all processes spawned by it have
-- terminated (except those spawned by the child with the
-- @CREATE_BREAKAWAY_FROM_JOB@ @CreateProcess@ flag).
--
-- Note, however, that, because of platform limitations, the exit code returned
-- by @waitForProcess@ and @getProcessExitCode@ cannot not be relied upon when
-- the child uses @exec@, even when 'use_process_jobs' is used. Specifically,
-- these functions will return the exit code of the *original child* (which
-- always exits with code 0, since it called @exec@), not the exit code of the
-- process which carried on with execution after @exec@. This is different from
-- the behavior prescribed by POSIX but is the best approximation that can be
-- realised under the restrictions of the Windows process model.
-- -----------------------------------------------------------------------------
-- | @readProcess@ forks an external process, reads its standard output
......@@ -642,30 +670,36 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
case p_ of
ClosedHandle e -> return e
OpenHandle h -> do
e <- alloca $ \pret -> do
-- don't hold the MVar while we call c_waitForProcess...
throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
modifyProcessHandle ph $ \p_' ->
case p_' of
ClosedHandle e -> return (p_', e)
OpenExtHandle{} -> return (p_', ExitFailure (-1))
OpenHandle ph' -> do
closePHANDLE ph'
code <- peek pret
let e = if (code == 0)
then ExitSuccess
else (ExitFailure (fromIntegral code))
return (ClosedHandle e, e)
when delegating_ctlc $
endDelegateControlC e
return e
-- don't hold the MVar while we call c_waitForProcess...
e <- waitForProcess' h
e' <- modifyProcessHandle ph $ \p_' ->
case p_' of
ClosedHandle e' -> return (p_', e')
OpenExtHandle{} -> fail "waitForProcess(OpenExtHandle): this cannot happen"
OpenHandle ph' -> do
closePHANDLE ph'
when delegating_ctlc $
endDelegateControlC e
return (ClosedHandle e, e)
return e'
#if defined(WINDOWS)
OpenExtHandle _ job iocp ->
maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite
where mkExitCode code | code == 0 = ExitSuccess
| otherwise = ExitFailure $ fromIntegral code
OpenExtHandle h job -> do
-- First wait for completion of the job...
waitForJobCompletion job
e <- waitForProcess' h
e' <- modifyProcessHandle ph $ \p_' ->
case p_' of
ClosedHandle e' -> return (p_', e')
OpenHandle{} -> fail "waitForProcess(OpenHandle): this cannot happen"
OpenExtHandle ph' job' -> do
closePHANDLE ph'
closePHANDLE job'
when delegating_ctlc $
endDelegateControlC e
return (ClosedHandle e, e)
return e'
#else
OpenExtHandle _ _job _iocp ->
OpenExtHandle _ _job ->
return $ ExitFailure (-1)
#endif
where
......@@ -676,6 +710,17 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
-- https://github.com/haskell/process/pull/58 for further discussion
lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m
waitForProcess' :: PHANDLE -> IO ExitCode
waitForProcess' h = alloca $ \pret -> do
throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
mkExitCode <$> peek pret
mkExitCode :: CInt -> ExitCode
mkExitCode code
| code == 0 = ExitSuccess
| otherwise = ExitFailure (fromIntegral code)
-- ----------------------------------------------------------------------------
-- getProcessExitCode
......@@ -715,7 +760,7 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do
where getHandle :: ProcessHandle__ -> Maybe PHANDLE
getHandle (OpenHandle h) = Just h
getHandle (ClosedHandle _) = Nothing
getHandle (OpenExtHandle h _ _) = Just h
getHandle (OpenExtHandle h _) = Just h
-- If somebody is currently holding the waitpid lock, we don't want to
-- accidentally remove the pid from the process table.
......
......@@ -103,7 +103,7 @@ 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 systems this flag is ignored.
-- to finish before unblocking. On POSIX systems this flag is ignored. See $exec-on-windows for details.
--
-- Default: @False@
--
......@@ -186,8 +186,13 @@ data StdStream
completion. This requires two handles. A process job handle and
a events handle to monitor.
-}
data ProcessHandle__ = OpenHandle PHANDLE
| OpenExtHandle PHANDLE PHANDLE PHANDLE
data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE }
| OpenExtHandle { phdlProcessHandle :: PHANDLE
-- ^ the process
, phdlJobHandle :: PHANDLE
-- ^ the job containing the process and
-- its subprocesses
}
| ClosedHandle ExitCode
data ProcessHandle
= ProcessHandle { phandle :: !(MVar ProcessHandle__)
......
......@@ -22,7 +22,6 @@ 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
......@@ -60,11 +59,11 @@ 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 -> PHANDLE -> PHANDLE -> IO ProcessHandle
mkProcessHandle h job io = do
m <- if job == nullPtr && io == nullPtr
mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle
mkProcessHandle h job = do
m <- if job == nullPtr
then newMVar (OpenHandle h)
else newMVar (OpenExtHandle h job io)
else newMVar (OpenExtHandle h job)
_ <- mkWeakMVar m (processHandleFinaliser m)
l <- newMVar ()
return (ProcessHandle m False l)
......@@ -74,9 +73,8 @@ processHandleFinaliser m =
modifyMVar_ m $ \p_ -> do
case p_ of
OpenHandle ph -> closePHANDLE ph
OpenExtHandle ph job io -> closePHANDLE ph
OpenExtHandle ph job -> closePHANDLE ph
>> closePHANDLE job
>> closePHANDLE io
_ -> return ()
return (error "closed process handle")
......@@ -114,7 +112,6 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
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
......@@ -145,15 +142,13 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
.|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))
use_job
hJob
hIOcpPort
hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
phJob <- peek hJob
phIOCP <- peek hIOcpPort
ph <- mkProcessHandle proc_handle phJob phIOCP
ph <- mkProcessHandle proc_handle phJob
return ProcRetHandles { hStdInput = hndStdInput
, hStdOutput = hndStdOutput
, hStdError = hndStdError
......@@ -187,44 +182,21 @@ terminateJob :: ProcessHandle -> CUInt -> IO Bool
terminateJob jh ecode =
withProcessHandle jh $ \p_ -> do
case p_ of
ClosedHandle _ -> return False
OpenHandle _ -> return False
OpenExtHandle _ job _ -> c_terminateJobObject job ecode
ClosedHandle _ -> return False
OpenHandle _ -> return False
OpenExtHandle _ job -> c_terminateJobObject job ecode
timeout_Infinite :: CUInt
timeout_Infinite = 0xFFFFFFFF
waitForJobCompletion :: PHANDLE
-> PHANDLE
-> CUInt
-> IO (Maybe CInt)
waitForJobCompletion job io timeout =
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 :: 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)
waitForJobCompletion :: PHANDLE -- ^ job handle
-> IO ()
waitForJobCompletion job =
throwErrnoIf_ not "waitForJobCompletion" $ c_waitForJobCompletion job
-- ----------------------------------------------------------------------------
-- 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
......@@ -234,12 +206,7 @@ foreign import WINDOWS_CCONV unsafe "TerminateJobObject"
foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
c_waitForJobCompletion
:: PHANDLE
-> PHANDLE
-> CUInt
-> Ptr CInt
-> FunPtr (SetterDef)
-> FunPtr (GetterDef)
-> IO CInt
-> IO Bool
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
......@@ -255,7 +222,6 @@ foreign import ccall unsafe "runInteractiveProcess"
-> CInt -- flags
-> Bool -- useJobObject
-> Ptr PHANDLE -- Handle to Job
-> Ptr PHANDLE -- Handle to I/O Completion Port
-> IO PHANDLE
commandToProcess
......@@ -338,7 +304,7 @@ createPipeInternal = do
(do readh <- fdToHandle readfd
writeh <- fdToHandle writefd
return (readh, writeh)) `onException` (close' readfd >> close' writefd)
createPipeInternalFd :: IO (FD, FD)
createPipeInternalFd = do
allocaArray 2 $ \ pfds -> do
......@@ -365,9 +331,9 @@ interruptProcessGroupOfInternal ph = do
case p_ of
ClosedHandle _ -> return ()
_ -> do let h = case p_ of
OpenHandle x -> x
OpenExtHandle x _ _ -> x
_ -> error "interruptProcessGroupOfInternal"
OpenHandle x -> x
OpenExtHandle x _ -> x
_ -> error "interruptProcessGroupOfInternal"
#if mingw32_HOST_OS
pid <- getProcessId h
generateConsoleCtrlEvent cTRL_BREAK_EVENT pid
......
......@@ -569,29 +569,6 @@ createJob ()
return NULL;
}
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;
}
/* Note [Windows exec interaction]
The basic issue that process jobs tried to solve is this:
......@@ -629,7 +606,7 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
wchar_t *environment,
int fdStdIn, int fdStdOut, int fdStdErr,
int *pfdStdInput, int *pfdStdOutput, int *pfdStdError,
int flags, bool useJobObject, HANDLE *hJob, HANDLE *hIOcpPort)
int flags, bool useJobObject, HANDLE *hJob)
{
STARTUPINFO sInfo;
PROCESS_INFORMATION pInfo;
......@@ -750,16 +727,8 @@ runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory,
{
goto cleanup_err;
}
// Create the completion port and attach it to the job
*hIOcpPort = createCompletionPort(*hJob);
if (!*hIOcpPort)
{
goto cleanup_err;
}
} else {
*hJob = NULL;
*hIOcpPort = NULL;
}
if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo))
......@@ -803,7 +772,6 @@ cleanup_err:
if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead);
if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite);
if (useJobObject && hJob && *hJob ) CloseHandle(*hJob);
if (useJobObject && hIOcpPort && *hIOcpPort) CloseHandle(*hIOcpPort);
maperrno();
return NULL;
......@@ -886,78 +854,68 @@ waitForProcess (ProcHandle handle, int *pret)
return -1;
}
// Returns true on success.
int
waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode, setterDef set, getterDef get )
waitForJobCompletion ( HANDLE hJob )
{
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)) {
// If event wasn't meant of us, keep listening.
if ((HANDLE)CompletionKey != hJob)
continue;
switch (CompletionCode)
{
case JOB_OBJECT_MSG_NEW_PROCESS:
{
// A new child process is born.
// 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 = get((DWORD)(uintptr_t)Overlapped);
if (GetExitCodeProcess(pHwnd, (DWORD *)pExitCode) == 0)
{
maperrno();
return 1;
}
// Check to see if the child has actually exited.
if (*(DWORD *)pExitCode == STILL_ACTIVE)
waitForProcess ((ProcHandle)pHwnd, pExitCode);
}
break;
case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO:
// All processes in the tree are done.
return 0;
default:
break;
int process_count = 16;
JOBOBJECT_BASIC_PROCESS_ID_LIST *pid_list = NULL;
while (true) {
if (pid_list == NULL) {
pid_list = malloc(sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST) + sizeof(ULONG_PTR) * process_count);
pid_list->NumberOfAssignedProcesses = process_count;
}
// Find a process in the job...
bool success = QueryInformationJobObject(
hJob,
JobObjectBasicProcessIdList,
pid_list,
sizeof(JOBOBJECT_BASIC_PROCESS_ID_LIST),
NULL);
if (!success && GetLastError() == ERROR_MORE_DATA) {
process_count *= 2;
free(pid_list);
pid_list = NULL;
continue;
} else if (!success) {
free(pid_list);
maperrno();
return false;
}
if (pid_list->NumberOfProcessIdsInList == 0) {
// We're done
free(pid_list);
return true;
}
HANDLE pHwnd = OpenProcess(SYNCHRONIZE, TRUE, pid_list->ProcessIdList[0]);
if (pHwnd == NULL) {
switch (GetLastError()) {
case ERROR_INVALID_PARAMETER:
case ERROR_INVALID_HANDLE:
// Presumably the process terminated; try again.
continue;
default:
free(pid_list);
maperrno();
return false;
}
}
}
// 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;
}
// Wait for it to finish...
if (WaitForSingleObject(pHwnd, INFINITE) != WAIT_OBJECT_0) {
free(pid_list);
maperrno();
CloseHandle(pHwnd);
return false;
}
return 0;
// The process signalled, loop again to try the next process.
CloseHandle(pHwnd);
}
}
#endif /* Win32 */
......@@ -2,6 +2,10 @@
## Unreleased changes
* Fix several bugs on Windows where use of process jobs would result
in the process being prematurely terminated. See
[#168](https://github.com/haskell/process/168).
## 1.6.7.0 *November 2019*
* Fix a race condition on Windows that happens when you use process jobs and one of
......
......@@ -86,14 +86,13 @@ extern ProcHandle runInteractiveProcess( wchar_t *cmd,
int *pfdStdError,
int flags,
bool useJobObject,
HANDLE *hJob,
HANDLE *hIOcpPort );
HANDLE *hJob );
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, setterDef set, getterDef get );
extern int waitForJobCompletion( HANDLE hJob );
#endif
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment