[commit: packages/process] master: Add tests for the delegated control-C handling (#2301) (1b1f18b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/process

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1b1f18b89d23094f4411be534c493a0da8aeadb9/process

>---------------------------------------------------------------

commit 1b1f18b89d23094f4411be534c493a0da8aeadb9
Author: Duncan Coutts <duncan at well-typed.com>
Date:   Thu Nov 14 20:10:16 2013 +0000

    Add tests for the delegated control-C handling (#2301)
    
    Authored-by: Duncan Coutts <duncan at well-typed.com>
    Signed-off-by: Herbert Valerio Riedel <hvr at gnu.org>


>---------------------------------------------------------------

1b1f18b89d23094f4411be534c493a0da8aeadb9
 tests/all.T             |    1 +
 tests/process011.hs     |   77 +++++++++++++++++++++++++++++++++++++++++++++++
 tests/process011.stdout |   12 ++++++++
 3 files changed, 90 insertions(+)

diff --git a/tests/all.T b/tests/all.T
index f77fe8e..292f730 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -32,5 +32,6 @@ test('T4889', normal, compile_and_run, [''])
 
 test('process009', when(opsys('mingw32'), skip), compile_and_run, [''])
 test('process010', normal, compile_and_run, [''])
+test('process011', when(opsys('mingw32'), skip), compile_and_run, [''])
 
 test('T8343', normal, compile_and_run, [''])
diff --git a/tests/process011.hs b/tests/process011.hs
new file mode 100644
index 0000000..fdcb8cf
--- /dev/null
+++ b/tests/process011.hs
@@ -0,0 +1,77 @@
+import System.Process
+import System.IO
+import Control.Exception
+import Control.Concurrent
+import Data.List
+
+-- Test control-C delegation (#2301)
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+
+  putStrLn "===================== test 1"
+
+  -- shell kills itself with SIGINT,
+  -- delegation off, exit code (death by signal) reported as normal
+  do let script = intercalate "; "
+                    [ "kill -INT $$"
+                    , "exit 42" ]
+     (_,_,_,p) <- createProcess (shell script) { delegate_ctlc = False }
+     waitForProcess p >>= print
+
+  putStrLn "===================== test 2"
+
+  -- shell kills itself with SIGINT,
+  -- delegation on, so expect to throw UserInterrupt
+  do let script = intercalate "; "
+                    [ "kill -INT $$"
+                    , "exit 42" ]
+     (_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
+     (waitForProcess p >>= print)
+       `catchUserInterrupt` \e -> putStrLn $ "caught: " ++ show e
+
+  putStrLn "===================== test 3"
+
+  -- shell sends itself SIGINT but traps it,
+  -- delegation on, but the shell terminates normally so just normal exit code
+  do let script = intercalate "; "
+                    [ "trap 'echo shell trapped SIGINT' INT"
+                    , "kill -INT $$"
+                    , "exit 42" ]
+     (_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
+     waitForProcess p >>= print
+
+  putStrLn "===================== test 4"
+
+  -- shell sends us SIGINT.
+  -- delegation on, so we should not get the SIGINT ourselves
+  -- shell terminates normally so just normal exit code
+  do let script = intercalate "; "
+                    [ "kill -INT $PPID"
+                    , "kill -INT $PPID"
+                    , "exit 42" ]
+     (_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
+     waitForProcess p >>= print
+
+  putStrLn "===================== test 5"
+
+  -- shell sends us SIGINT.
+  -- delegation off, so we should get the SIGINT ourselves (async)
+  do let script = intercalate "; "
+                    [ "kill -INT $PPID"
+                    , "exit 42" ]
+     (_,_,_,p) <- createProcess (shell script) { delegate_ctlc = False }
+     exit <- waitForProcess p
+     -- need to allow for the async exception to arrive
+     threadDelay 1000000
+     -- we should never make it to here...
+     putStrLn "never caught interrupt"
+     print exit
+   `catchUserInterrupt` \e -> putStrLn $ "caught: " ++ show e
+
+  putStrLn "===================== done"
+
+catchUserInterrupt :: IO a -> (AsyncException -> IO a) -> IO a
+catchUserInterrupt =
+  catchJust (\e -> case e of UserInterrupt -> Just e; _ -> Nothing)
diff --git a/tests/process011.stdout b/tests/process011.stdout
new file mode 100644
index 0000000..2c9a46f
--- /dev/null
+++ b/tests/process011.stdout
@@ -0,0 +1,12 @@
+===================== test 1
+ExitFailure (-2)
+===================== test 2
+caught: user interrupt
+===================== test 3
+shell trapped SIGINT
+ExitFailure 42
+===================== test 4
+ExitFailure 42
+===================== test 5
+caught: user interrupt
+===================== done