diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -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 () diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -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_ diff --git a/cbits/posix/common.h b/cbits/posix/common.h --- a/cbits/posix/common.h +++ b/cbits/posix/common.h @@ -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 diff --git a/cbits/posix/find_executable.c b/cbits/posix/find_executable.c --- a/cbits/posix/find_executable.c +++ b/cbits/posix/find_executable.c @@ -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 diff --git a/cbits/posix/fork_exec.c b/cbits/posix/fork_exec.c --- a/cbits/posix/fork_exec.c +++ b/cbits/posix/fork_exec.c @@ -1,3 +1,6 @@ +/* ensure that execvpe is provided if possible */ +#define _GNU_SOURCE 1 + #include "common.h" #include @@ -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 diff --git a/cbits/posix/posix_spawn.c b/cbits/posix/posix_spawn.c --- a/cbits/posix/posix_spawn.c +++ b/cbits/posix/posix_spawn.c @@ -5,7 +5,7 @@ #include #include -#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 { diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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) diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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 + #include + #include + #include + +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` diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -31,6 +31,39 @@ #include ]) +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 + #include + #include + #include + ], [[ + 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 diff --git a/include/HsProcessConfig.h.in b/include/HsProcessConfig.h.in --- a/include/HsProcessConfig.h.in +++ b/include/HsProcessConfig.h.in @@ -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 does not define. */ #undef pid_t diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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