summaryrefslogtreecommitdiff
path: root/lib/ProcessUtils.hs
blob: 4e3ac38d1cb81f34ad0ad72251fa7e8bb3ac4d0a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
module ProcessUtils
    ( ExitCode(ExitFailure,ExitSuccess)
    , systemEnv
    ) where

import GHC.IO.Exception ( ioException, IOErrorType(..) )
import System.Process
import System.Posix.Signals
import System.Process.Internals (runGenProcess_,defaultSignal)
import System.Environment
import Data.Maybe ( isNothing )
import System.IO.Error ( mkIOError, ioeSetErrorString ) 
import System.Exit ( ExitCode(..) )


-- | systemEnv
-- This is like System.Process.system except that it lets you set
-- some environment variables.
systemEnv :: [(String, String)] -> String -> IO ExitCode
systemEnv _    ""  = 
    ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
systemEnv vars cmd = do
    env0 <- getEnvironment
    let env1 = filter (isNothing . flip lookup vars . fst) env0
        env = vars ++ env1
    syncProcess "system" $ (shell cmd) {env=Just env}
 where
    -- This is a non-exported function from System.Process
    syncProcess fun c = do
      -- The POSIX version of system needs to do some manipulation of signal
      -- handlers.  Since we're going to be synchronously waiting for the child,
      -- we want to ignore ^C in the parent, but handle it the default way
      -- in the child (using SIG_DFL isn't really correct, it should be the
      -- original signal handler, but the GHC RTS will have already set up
      -- its own handler and we don't want to use that).
      old_int  <- installHandler sigINT  Ignore Nothing
      old_quit <- installHandler sigQUIT Ignore Nothing
      (_,_,_,p) <- runGenProcess_ fun c
            (Just defaultSignal) (Just defaultSignal)
      r <- waitForProcess p
      _ <- installHandler sigINT  old_int Nothing
      _ <- installHandler sigQUIT old_quit Nothing
      return r