Remove doubleFork, handle SIGCHLD

Ignore-this: f9b1a65b4f0622922f80ad2ab6c5a52f
This is a rather big change.  Rather than make spawned processes become
children of init, we handle them in xmonad.  As a side effect of this change,
we never need to use waitForProcess in any contrib module -- in fact, doing so
will raise an exception.  The main benefit to handling SIGCHLD is that xmonad
can now be started with 'exec', and will correctly clean up after inherited
child processes.

darcs-hash:20090116204742-25a6b-9594fc6cdfcd5552894b64b4b6137f8a7cf2021d

3 files changed, 32 insertions, 19 deletions

diff --git a/Main.hs b/Main.hs
index 84eca32..29ae822 100644
--- a/Main.hs
+++ b/Main.hs
@@ -32,6 +32,7 @@ import qualified Properties
 -- for xmonad, and if it doesn't find one, just launches the default.
 main :: IO ()
 main = do
+    installSignalHandlers -- important to ignore SIGCHLD to avoid zombies
     args <- getArgs
     let launch = catchIO buildLaunch >> xmonad defaultConfig
     case args of
diff --git a/XMonad/Core.hs b/XMonad/Core.hs
index b2eb959..eedeed4 100644
--- a/XMonad/Core.hs
+++ b/XMonad/Core.hs
@@ -24,28 +24,31 @@ module XMonad.Core (
     XConf(..), XConfig(..), LayoutClass(..),
     Layout(..), readsLayout, Typeable, Message,
     SomeMessage(..), fromMessage, LayoutMessages(..),
-    runX, catchX, userCode, userCodeDef, io, catchIO, doubleFork,
+    runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers,
     withDisplay, withWindowSet, isRoot, runOnWorkspaces,
-    getAtom, spawn, getXMonadDir, recompile, trace, whenJust, whenX,
+    getAtom, spawn, spawnPID, getXMonadDir, recompile, trace, whenJust, whenX,
     atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, ManageHook, Query(..), runQuery
   ) where
 
 import XMonad.StackSet hiding (modify)
 
 import Prelude hiding ( catch )
-import Control.Exception (catch, bracket, throw, Exception(ExitException))
+import Control.Exception (catch, try, bracket, throw, Exception(ExitException))
 import Control.Applicative
 import Control.Monad.State
 import Control.Monad.Reader
 import System.IO
 import System.Info
-import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession)
+import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus)
+import System.Posix.Signals
+import System.Posix.Types (ProcessID)
 import System.Process
 import System.Directory
 import System.Exit
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras (Event)
 import Data.Typeable
+import Data.Maybe (isJust)
 import Data.Monoid
 import Data.Maybe (fromMaybe)
 
@@ -349,17 +352,10 @@ catchIO f = io (f `catch` \e -> hPrint stderr e >> hFlush stderr)
 -- | spawn. Launch an external application. Specifically, it double-forks and
 -- runs the 'String' you pass as a command to /bin/sh.
 spawn :: MonadIO m => String -> m ()
-spawn x = doubleFork $ executeFile "/bin/sh" False ["-c", x] Nothing
-
--- | Double fork and execute an 'IO' action (usually one of the exec family of
--- functions)
-doubleFork :: MonadIO m => IO () -> m ()
-doubleFork m = io $ do
-    pid <- forkProcess $ do
-        forkProcess (createSession >> m)
-        exitWith ExitSuccess
-    getProcessStatus True False pid
-    return ()
+spawn x = spawnPID x >> return ()
+
+spawnPID :: MonadIO m => String -> m ProcessID
+spawnPID x = io $ forkProcess $ executeFile "/bin/sh" False ["-c", x] Nothing
 
 -- | This is basically a map function, running a function in the 'X' monad on
 -- each workspace with the output of that function being the modified workspace.
@@ -404,10 +400,15 @@ recompile force = io $ do
     binT <- getModTime bin
     if (force || srcT > binT)
       then do
+        -- temporarily disable SIGCHLD ignoring:
+        installHandler sigCHLD Default Nothing
         status <- bracket (openFile err WriteMode) hClose $ \h -> do
             waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0", "-o",binn] (Just dir)
                                     Nothing Nothing Nothing (Just h)
 
+        -- re-enable SIGCHLD:
+        installSignalHandlers
+
         -- now, if it fails, run xmessage to let the user know:
         when (status /= ExitSuccess) $ do
             ghcErr <- readFile err
@@ -417,7 +418,8 @@ recompile force = io $ do
             -- nb, the ordering of printing, then forking, is crucial due to
             -- lazy evaluation
             hPutStrLn stderr msg
-            doubleFork $ executeFile "xmessage" True ["-default", "okay", msg] Nothing
+            forkProcess $ executeFile "xmessage" True ["-default", "okay", msg] Nothing
+            return ()
         return (status == ExitSuccess)
       else return True
  where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing)
@@ -434,3 +436,14 @@ whenX a f = a >>= \b -> when b f
 -- be found in your .xsession-errors file
 trace :: MonadIO m => String -> m ()
 trace = io . hPutStrLn stderr
+
+-- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to
+-- avoid zombie processes, and clean up any extant zombie processes.
+installSignalHandlers :: MonadIO m => m ()
+installSignalHandlers = io $ do
+    installHandler openEndedPipe Ignore Nothing
+    installHandler sigCHLD Ignore Nothing
+    try $ fix $ \more -> do
+        x <- getAnyProcessStatus False False
+        when (isJust x) more
+    return ()
diff --git a/XMonad/Main.hsc b/XMonad/Main.hsc
index 531939e..99bc77f 100644
--- a/XMonad/Main.hsc
+++ b/XMonad/Main.hsc
@@ -27,7 +27,6 @@ import Foreign.C
 import Foreign.Ptr
 
 import System.Environment (getArgs)
-import System.Posix.Signals
 
 import Graphics.X11.Xlib hiding (refreshKeyboardMapping)
 import Graphics.X11.Xlib.Extras
@@ -57,8 +56,8 @@ xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
 xmonad initxmc = do
     -- setup locale information from environment
     withCString "" $ c_setlocale (#const LC_ALL)
-    -- ignore SIGPIPE
-    installHandler openEndedPipe Ignore Nothing
+    -- ignore SIGPIPE and SIGCHLD
+    installSignalHandlers
     -- First, wrap the layout in an existential, to keep things pretty:
     let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc }
     dpy   <- openDisplay ""