process 1.6.13.2 → 1.6.14.0
raw patch · 12 files changed
+382/−86 lines, 12 files
Files
- System/Process.hs +15/−9
- System/Process/Internals.hs +6/−1
- cbits/posix/common.h +2/−2
- cbits/posix/find_executable.c +73/−14
- cbits/posix/fork_exec.c +11/−3
- cbits/posix/posix_spawn.c +3/−2
- changelog.md +10/−0
- configure +55/−0
- configure.ac +33/−0
- include/HsProcessConfig.h.in +3/−0
- process.cabal +2/−2
- test/main.hs +169/−53
System/Process.hs view
@@ -676,6 +676,7 @@ -- waitForProcess {- | Waits for the specified process to terminate, and returns its exit code.+On Unix systems, may throw 'UserInterrupt' when using 'delegate_ctlc'. GHC Note: in order to call @waitForProcess@ without blocking all the other threads in the system, you must compile the program with@@ -683,7 +684,8 @@ Note that it is safe to call @waitForProcess@ for the same process in multiple threads. When the process ends, threads blocking on this call will wake in-FIFO order.+FIFO order. When using 'delegate_ctlc' and the process is interrupted, only+the first waiting thread will throw 'UserInterrupt'. (/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ indicates that the child was terminated by signal @/signum/@.@@ -703,15 +705,17 @@ OpenHandle h -> do -- don't hold the MVar while we call c_waitForProcess... e <- waitForProcess' h- e' <- modifyProcessHandle ph $ \p_' ->+ (e', was_open) <- modifyProcessHandle ph $ \p_' -> case p_' of- ClosedHandle e' -> return (p_', e')+ ClosedHandle e' -> return (p_', (e', False)) OpenExtHandle{} -> fail "waitForProcess(OpenExtHandle): this cannot happen" OpenHandle ph' -> do closePHANDLE ph'- when delegating_ctlc $- endDelegateControlC e- return (ClosedHandle e, e)+ return (ClosedHandle e, (e, True))+ -- endDelegateControlC after closing the handle, since it+ -- may throw UserInterrupt+ when (was_open && delegating_ctlc) $+ endDelegateControlC e return e' #if defined(WINDOWS) OpenExtHandle h job -> do@@ -725,9 +729,8 @@ OpenExtHandle ph' job' -> do closePHANDLE ph' closePHANDLE job'- when delegating_ctlc $- endDelegateControlC e return (ClosedHandle e, e)+ -- omit endDelegateControlC since it's a no-op on Windows return e' #else OpenExtHandle _ _job ->@@ -761,7 +764,8 @@ @'Just' e@ is returned where @e@ is the exit code of the process. On Unix systems, see 'waitForProcess' for the meaning of exit codes-when the process died as the result of a signal.+when the process died as the result of a signal. May throw+'UserInterrupt' when using 'delegate_ctlc'. -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)@@ -784,6 +788,8 @@ let e | code == 0 = ExitSuccess | otherwise = ExitFailure (fromIntegral code) return (ClosedHandle e, (Just e, True))+ -- endDelegateControlC after closing the handle, since it+ -- may throw UserInterrupt case m_e of Just e | was_open && delegating_ctlc -> endDelegateControlC e _ -> return ()
System/Process/Internals.hs view
@@ -85,7 +85,12 @@ -- -- @since 1.2.1.0 createProcess_- :: String -- ^ function name (for error messages)+ :: String+ -- ^ Function name (for error messages).+ --+ -- This can be any 'String', but will typically be the name of the caller.+ -- E.g., 'spawnProcess' passes @"spawnProcess"@ here when calling+ -- 'createProcess_'. -> CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess_ msg proc_ = unwrapHandles `fmap` createProcess_Internal msg proc_
cbits/posix/common.h view
@@ -25,8 +25,8 @@ int get_max_fd(void); // defined in find_executable.c-#if !defined(HAVE_execvpe)-char *find_executable(char *filename);+#if !defined(HAVE_EXECVPE)+char *find_executable(char *workingDirectory, char *filename); #endif // defined in fork_exec.c
cbits/posix/find_executable.c view
@@ -12,18 +12,48 @@ #include "common.h" // the below is only necessary when we need to emulate execvpe.-#if !defined(HAVE_execvpe)+#if !defined(HAVE_EXECVPE) -/* Return true if the given file exists and is an executable. */-static bool is_executable(const char *path) {- return access(path, X_OK) == 0;+/* A quick check for whether the given path is absolute. */+static bool is_absolute(const char *path) {+ return path[0] == '/'; } +static char *concat_paths(const char *path1, const char *path2) {+ if (is_absolute(path2)) {+ return strdup(path2);+ } else {+ int len = strlen(path1) + 1 + strlen(path2) + 1;+ char *tmp = malloc(len);+ int ret = snprintf(tmp, len, "%s/%s", path1, path2);+ if (ret < 0) {+ free(tmp);+ return NULL;+ }+ return tmp;+ }+}++/* Return true if the given file exists and is an executable, optionally+ * relative to the given working directory.+ */+static bool is_executable(char *working_dir, const char *path) {+ if (working_dir && !is_absolute(path)) {+ char *tmp = concat_paths(working_dir, path);+ bool ret = access(tmp, X_OK) == 0;+ free(tmp);+ return ret;+ } else {+ return access(path, X_OK) == 0;+ }+}+ /* Find an executable with the given filename in the given search path. The * result must be freed by the caller. Returns NULL if a matching file is not * found. */-static char *find_in_search_path(char *search_path, const char *filename) {+static char *find_in_search_path(char *working_dir, char *search_path, const char *filename) {+ int workdir_len = strlen(working_dir); const int filename_len = strlen(filename); char *tokbuf; char *path = strtok_r(search_path, ":", &tokbuf);@@ -34,13 +64,21 @@ #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wmaybe-uninitialized" #endif- const int tmp_len = filename_len + 1 + strlen(path) + 1;+ char *tmp;+ if (is_absolute(path)) {+ const int tmp_len = strlen(path) + 1 + filename_len + 1;+ tmp = malloc(tmp_len);+ snprintf(tmp, tmp_len, "%s/%s", path, filename);+ } else {+ const int tmp_len = workdir_len + 1 + strlen(path) + 1 + filename_len + 1;+ tmp = malloc(tmp_len);+ snprintf(tmp, tmp_len, "%s/%s/%s", working_dir, path, filename);+ } #if defined(__GNUC__) && __GNUC__ == 6 && __GNUC_MINOR__ == 3 #pragma GCC diagnostic pop #endif- char *tmp = malloc(tmp_len);- snprintf(tmp, tmp_len, "%s/%s", path, filename);- if (is_executable(tmp)) {++ if (is_executable(working_dir, tmp)) { return tmp; } else { free(tmp);@@ -74,15 +112,36 @@ return strdup(":"); } -/* Find the given executable in the executable search path. */-char *find_executable(char *filename) {- /* If it's an absolute or relative path name, it's easy. */- if (strchr(filename, '/') && is_executable(filename)) {+/* Find the given executable in the executable search path relative to+ * workingDirectory (or the current directory, if NULL).+ * N.B. the caller is responsible for free()ing the result.+ */+char *find_executable(char *working_dir, char *filename) {+ /* Drop trailing slash from working directory if necessary */+ if (working_dir) {+ int workdir_len = strlen(working_dir);+ if (working_dir[workdir_len-1] == '/') {+ working_dir[workdir_len-1] = '\0';+ }+ }++ if (is_absolute(filename)) {+ /* If it's an absolute path name, it's easy. */ return filename;++ } else if (strchr(filename, '/')) {+ /* If it's a relative path name, we must look for executables relative+ * to the working directory. */+ if (is_executable(working_dir, filename)) {+ return filename;+ } } + /* Otherwise look through the search path... */ char *search_path = get_executable_search_path();- return find_in_search_path(search_path, filename);+ char *result = find_in_search_path(working_dir, search_path, filename);+ free(search_path);+ return result; } #endif
cbits/posix/fork_exec.c view
@@ -1,3 +1,6 @@+/* ensure that execvpe is provided if possible */+#define _GNU_SOURCE 1+ #include "common.h" #include <sys/types.h>@@ -125,10 +128,15 @@ // we emulate this using fork and exec. However, to safely do so // we need to perform all allocations *prior* to forking. Consequently, we // need to find_executable before forking.-#if !defined(HAVE_execvpe)+#if !defined(HAVE_EXECVPE) char *exec_path; if (environment) {- exec_path = find_executable(args[0]);+ exec_path = find_executable(workingDirectory, args[0]);+ if (exec_path == NULL) {+ errno = -ENOENT;+ *failed_doing = "find_executable";+ return -1;+ } } #endif @@ -234,7 +242,7 @@ /* the child */ if (environment) {-#if defined(HAVE_execvpe)+#if defined(HAVE_EXECVPE) // XXX Check result execvpe(args[0], args, environment); #else
cbits/posix/posix_spawn.c view
@@ -5,7 +5,7 @@ #include <errno.h> #include <signal.h> -#if !defined(HAVE_POSIX_SPAWNP)+#if !defined(USE_POSIX_SPAWN) ProcHandle do_spawn_posix (char *const args[], char *workingDirectory, char **environment,@@ -159,7 +159,7 @@ #if defined(HAVE_POSIX_SPAWN_SETPGROUP) spawn_flags |= POSIX_SPAWN_SETPGROUP; #else- goto not_supported;+ goto not_supported; #endif } @@ -201,6 +201,7 @@ r = posix_spawnp(&pid, args[0], &fa, &sa, args, environment ? environment : environ); if (r != 0) {+ errno = r; // posix_spawn doesn't necessarily set errno; see #227. *failed_doing = "posix_spawnp"; goto fail; } else {
changelog.md view
@@ -1,5 +1,15 @@ # Changelog for [`process` package](http://hackage.haskell.org/package/process) +## 1.6.14.0 *February 2022*++* posix: Ensure that `errno` is set after `posix_spawnp` fails [#228](https://github.com/haskell/process/pull/228)+* Fix `waitForProcess` not closing process handles with `delegate_ctlc` [#231](https://github.com/haskell/process/pull/231)+* Don't use `posix_spawn` on platforms where it does not report `ENOENT` in caes where the+ requested executable does not exist [#224](https://github.com/haskell/process/issues/224)+* Ensure that `find_executable` correctly-locates executables when a change in+ working directory is requested [#219](https://github.com/haskell/process/issues/219)+* Fix capitalization error allowing `execvpe` to be used when available.+ ## 1.6.13.2 *July 2021* * `posix_spawn`: Don't attempt to `dup2` identical fds [#214](https://github.com/haskell/process/pull/214)
configure view
@@ -3907,6 +3907,61 @@ _ACEOF +if test "$ac_cv_func_posix_spawnp" = "yes"; then++ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether posix_spawn reports errors sensibly" >&5+$as_echo_n "checking whether posix_spawn reports errors sensibly... " >&6; }+ if test "$cross_compiling" = yes; then :+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "cannot run test program while cross compiling+See \`config.log' for more details" "$LINENO" 5; }+else+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++ #include <stddef.h>+ #include <stdbool.h>+ #include <errno.h>+ #include <spawn.h>++int+main ()+{++ pid_t pid;+ char *prog = "__nonexistent_program__";+ char *args[] = {prog, NULL};+ char *env[] = {NULL};++ // This should fail with ENOENT+ int ret = posix_spawnp(&pid, prog, NULL, NULL, args, env);+ bool okay = ret == ENOENT;+ return !okay;+++ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_run "$LINENO"; then :++$as_echo "#define USE_POSIX_SPAWN /**/" >>confdefs.h++ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5+$as_echo "yes" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, falling back to fork/exec" >&5+$as_echo "no, falling back to fork/exec" >&6; }++fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \+ conftest.$ac_objext conftest.beam conftest.$ac_ext+fi++fi++ for fp_const_name in SIG_DFL SIG_IGN do as_fp_Cache=`$as_echo "fp_cv_const_$fp_const_name" | $as_tr_sh`
configure.ac view
@@ -31,6 +31,39 @@ #include <spawn.h> ]) +if test "$ac_cv_func_posix_spawnp" = "yes"; then+ dnl On OpenBSD posix_spawnp doesn't report ENOENT when+ dnl the user attempts to spawn a process with a non-existent+ dnl executable. Don't attempt to use such posix_spawn+ dnl implementations to ensure errors are reported correctly.+ dnl See #224.++ AC_MSG_CHECKING(whether posix_spawn reports errors sensibly)+ AC_RUN_IFELSE(+ [AC_LANG_PROGRAM([+ #include <stddef.h>+ #include <stdbool.h>+ #include <errno.h>+ #include <spawn.h>+ ], [[+ pid_t pid;+ char *prog = "__nonexistent_program__";+ char *args[] = {prog, NULL};+ char *env[] = {NULL};++ // This should fail with ENOENT+ int ret = posix_spawnp(&pid, prog, NULL, NULL, args, env);+ bool okay = ret == ENOENT;+ return !okay;+ ]]+ )],+ [AC_DEFINE([USE_POSIX_SPAWN], [], [posix_spawn should be used])+ AC_MSG_RESULT(yes)],+ [AC_MSG_RESULT([no, falling back to fork/exec])]+ )+fi++ FP_CHECK_CONSTS([SIG_DFL SIG_IGN]) AC_OUTPUT
include/HsProcessConfig.h.in view
@@ -109,6 +109,9 @@ /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS +/* posix_spawn should be used */+#undef USE_POSIX_SPAWN+ /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t
process.cabal view
@@ -1,5 +1,5 @@ name: process-version: 1.6.13.2+version: 1.6.14.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE@@ -58,7 +58,7 @@ c-sources: cbits/win32/runProcess.c other-modules: System.Process.Windows- build-depends: Win32 >=2.2 && < 2.13+ build-depends: Win32 >=2.4 && < 2.13 -- ole32 and rpcrt4 are needed to create GUIDs for unique named pipes -- for process. extra-libraries: kernel32, ole32, rpcrt4
test/main.hs view
@@ -7,12 +7,14 @@ import System.Process import Control.Concurrent import Data.Char (isDigit)+import Data.IORef import Data.List (isInfixOf) import Data.Maybe (isNothing) import System.IO (hClose, openBinaryTempFile, hGetContents) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import System.Directory (getTemporaryDirectory, removeFile)+import GHC.Conc.Sync (getUncaughtExceptionHandler, setUncaughtExceptionHandler) ifWindows :: IO () -> IO () ifWindows action@@ -28,6 +30,26 @@ main :: IO () main = do+ testDoesNotExist+ testModifiers+ testSubdirectories+ testBinaryHandles+ testMultithreadedWait+ testInterruptMaskedWait+ testGetPid+ testReadProcess+ testInterruptWith+ testDoubleWait+ testKillDoubleWait+ putStrLn ">>> Tests passed successfully"++run :: String -> IO () -> IO ()+run label test = do+ putStrLn $ ">>> Running: " ++ label+ test++testDoesNotExist :: IO ()+testDoesNotExist = run "non-existent executable" $ do res <- handle (return . Left . isDoesNotExistError) $ do (_, _, _, ph) <- createProcess (proc "definitelydoesnotexist" []) { close_fds = True@@ -37,14 +59,14 @@ Left True -> return () _ -> error $ show res - let test name modifier = do- putStrLn $ "Running test: " ++ name+testModifiers :: IO ()+testModifiers = do+ let test name modifier = run ("modifier " ++ name) $ do (_, _, _, ph) <- createProcess $ modifier $ proc "echo" ["hello", "world"] ec <- waitForProcess ph- if ec == ExitSuccess- then putStrLn $ "Success running: " ++ name- else error $ "echo returned: " ++ show ec+ unless (ec == ExitSuccess)+ $ error $ "echo returned: " ++ show ec test "vanilla" id @@ -54,9 +76,9 @@ test "create_new_console" $ \cp -> cp { create_new_console = True } test "new_session" $ \cp -> cp { new_session = True } - putStrLn "Testing subdirectories"-- ifWindows $ withCurrentDirectory "exes" $ do+testSubdirectories :: IO ()+testSubdirectories = ifWindows $ run "subdirectories" $ do+ withCurrentDirectory "exes" $ do res1 <- readCreateProcess (proc "./echo.bat" []) "" unless ("parent" `isInfixOf` res1 && not ("child" `isInfixOf` res1)) $ error $ "echo.bat with cwd failed: " ++ show res1@@ -65,7 +87,8 @@ unless ("child" `isInfixOf` res2 && not ("parent" `isInfixOf` res2)) $ error $ "echo.bat with cwd failed: " ++ show res2 - putStrLn "Binary handles"+testBinaryHandles :: IO ()+testBinaryHandles = run "binary handles" $ do tmpDir <- getTemporaryDirectory bracket (openBinaryTempFile tmpDir "process-binary-test.bin")@@ -86,54 +109,147 @@ unless (bs == res') $ error $ "Unexpected result: " ++ show res' - do -- multithreaded waitForProcess- (_, _, _, p) <- createProcess (proc "sleep" ["0.1"])- me1 <- newEmptyMVar- _ <- forkIO . void $ waitForProcess p >>= putMVar me1- -- check for race / deadlock between waitForProcess and getProcessExitCode- e3 <- getProcessExitCode p- e2 <- waitForProcess p- e1 <- readMVar me1- unless (isNothing e3)- $ error $ "unexpected exit " ++ show e3- unless (e1 == ExitSuccess && e2 == ExitSuccess)- $ error "sleep exited with non-zero exit code!"-- do- putStrLn "interrupt masked waitForProcess"- (_, _, _, p) <- createProcess (proc "sleep" ["1.0"])- mec <- newEmptyMVar- tid <- mask_ . forkIO $- (waitForProcess p >>= putMVar mec . Just)- `catchThreadKilled` putMVar mec Nothing- killThread tid- eec <- takeMVar mec- case eec of- Nothing -> return ()- Just ec ->- if isWindows- then putStrLn "FIXME ignoring known failure on Windows"- else error $ "waitForProcess not interrupted: sleep exited with " ++ show ec+testMultithreadedWait :: IO ()+testMultithreadedWait = run "multithreaded wait" $ do+ (_, _, _, p) <- createProcess (proc "sleep" ["0.1"])+ me1 <- newEmptyMVar+ _ <- forkIO . void $ waitForProcess p >>= putMVar me1+ -- check for race / deadlock between waitForProcess and getProcessExitCode+ e3 <- getProcessExitCode p+ e2 <- waitForProcess p+ e1 <- readMVar me1+ unless (isNothing e3)+ $ error $ "unexpected exit " ++ show e3+ unless (e1 == ExitSuccess && e2 == ExitSuccess)+ $ error "sleep exited with non-zero exit code!" - putStrLn "testing getPid"- do- (_, Just out, _, p) <-- if isWindows- then createProcess $ (proc "sh" ["-c", "z=$$; cat /proc/$z/winpid"]) {std_out = CreatePipe}- else createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe}- pid <- getPid p- line <- hGetContents out- putStrLn $ " queried PID: " ++ show pid- putStrLn $ " PID reported by stdout: " ++ show line- _ <- waitForProcess p- hClose out- let numStdoutPid = read (takeWhile isDigit line) :: Pid- unless (Just numStdoutPid == pid) $+testInterruptMaskedWait :: IO ()+testInterruptMaskedWait = run "interrupt masked wait" $ do+ (_, _, _, p) <- createProcess (proc "sleep" ["1.0"])+ mec <- newEmptyMVar+ tid <- mask_ . forkIO $+ (waitForProcess p >>= putMVar mec . Just)+ `catchThreadKilled` putMVar mec Nothing+ killThread tid+ eec <- takeMVar mec+ case eec of+ Nothing -> return ()+ Just ec -> if isWindows then putStrLn "FIXME ignoring known failure on Windows"- else error "subprocess reported unexpected PID"+ else error $ "waitForProcess not interrupted: sleep exited with " ++ show ec - putStrLn "Tests passed successfully"+testGetPid :: IO ()+testGetPid = run "getPid" $ do+ (_, Just out, _, p) <-+ if isWindows+ then createProcess $ (proc "sh" ["-c", "z=$$; cat /proc/$z/winpid"]) {std_out = CreatePipe}+ else createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe}+ pid <- getPid p+ line <- hGetContents out+ putStrLn $ " queried PID: " ++ show pid+ putStrLn $ " PID reported by stdout: " ++ show line+ _ <- waitForProcess p+ hClose out+ let numStdoutPid = read (takeWhile isDigit line) :: Pid+ unless (Just numStdoutPid == pid) $+ if isWindows+ then putStrLn "FIXME ignoring known failure on Windows"+ else error "subprocess reported unexpected PID"++testReadProcess :: IO ()+testReadProcess = run "readProcess" $ do+ output <- readProcess "echo" ["hello", "world"] ""+ unless (output == "hello world\n") $+ error $ "unexpected output, got: " ++ output++-- | Test that withCreateProcess doesn't throw exceptions besides+-- the expected UserInterrupt when the child process is interrupted+-- by Ctrl-C.+testInterruptWith :: IO ()+testInterruptWith = unless isWindows $ run "interrupt withCreateProcess" $ do+ mpid <- newEmptyMVar+ forkIO $ do+ pid <- takeMVar mpid+ void $ readProcess "kill" ["-INT", show pid] ""++ -- collect unhandled exceptions in any threads (specifically+ -- the asynchronous 'waitForProcess' call from 'cleanupProcess')+ es <- collectExceptions $ do+ let sleep = (proc "sleep" ["10"]) { delegate_ctlc = True }+ res <- try $ withCreateProcess sleep $ \_ _ _ p -> do+ Just pid <- getPid p+ putMVar mpid pid+ waitForProcess p+ unless (res == Left UserInterrupt) $+ error $ "expected UserInterrupt, got " ++ show res++ unless (null es) $+ error $ "uncaught exceptions: " ++ show es++ where+ collectExceptions action = do+ oldHandler <- getUncaughtExceptionHandler+ flip finally (setUncaughtExceptionHandler oldHandler) $ do+ exceptions <- newIORef ([] :: [SomeException])+ setUncaughtExceptionHandler (\e -> atomicModifyIORef exceptions $ \es -> (e:es, ()))+ action+ threadDelay 1000 -- give some time for threads to finish+ readIORef exceptions++-- Test that we can wait without exception twice, if the process exited on its own.+testDoubleWait :: IO ()+testDoubleWait = run "run process, then wait twice" $ do+ let sleep = (proc "sleep" ["0"])+ (_, _, _, p) <- createProcess sleep+ res <- try $ waitForProcess p+ case res of+ Left e -> error $ "waitForProcess threw: " ++ show (e :: SomeException)+ Right ExitSuccess -> return ()+ Right exitCode -> error $ "unexpected exit code: " ++ show exitCode++ res2 <- try $ waitForProcess p+ case res2 of+ Left e -> error $ "second waitForProcess threw: " ++ show (e :: SomeException)+ Right ExitSuccess -> return ()+ Right exitCode -> error $ "unexpected exit code: " ++ show exitCode++-- Test that we can wait without exception twice, if the process was killed.+testKillDoubleWait :: IO ()+testKillDoubleWait = unless isWindows $ do+ run "terminate process, then wait twice (delegate_ctlc = False)" $ runTest "TERM" False+ run "terminate process, then wait twice (delegate_ctlc = True)" $ runTest "TERM" True+ run "interrupt process, then wait twice (delegate_ctlc = False)" $ runTest "INT" False+ run "interrupt process, then wait twice (delegate_ctlc = True)" $ runTest "INT" True+ where+ runTest sig delegate = do+ let sleep = (proc "sleep" ["10"])+ (_, _, _, p) <- createProcess sleep { delegate_ctlc = delegate }+ Just pid <- getPid p+ void $ readProcess "kill" ["-" ++ sig, show pid] ""++ res <- try $ waitForProcess p+ checkFirst sig delegate res++ res' <- try $ waitForProcess p+ checkSecond sig delegate res'++ checkFirst :: String -> Bool -> Either SomeException ExitCode -> IO ()+ checkFirst sig delegate res = case (sig, delegate) of+ ("INT", True) -> case res of+ Left e -> case fromException e of+ Just UserInterrupt -> putStrLn "result ok"+ Nothing -> error $ "expected UserInterrupt, got " ++ show e+ Right _ -> error $ "expected exception, got " ++ show res+ _ -> case res of+ Left e -> error $ "waitForProcess threw: " ++ show e+ Right ExitSuccess -> error "expected failure"+ _ -> putStrLn "result ok"++ checkSecond :: String -> Bool -> Either SomeException ExitCode -> IO ()+ checkSecond sig delegate res = case (sig, delegate) of+ ("INT", True) -> checkFirst "INT" False res+ _ -> checkFirst sig delegate res withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory new inner = do