{- System.Process enhancements, including additional ways of running - processes, and logging. - - Copyright 2012 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X, CreateProcess(..), StdHandle(..), readProcess, readProcess', readProcessEnv, writeReadProcessEnv, forceSuccessProcess, checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, createProcessChecked, createBackgroundProcess, processTranscript, processTranscript', withHandle, withBothHandles, withQuietOutput, createProcess, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, bothHandles, processHandle, devNull, ) where import qualified System.Process import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) import System.Process hiding (createProcess, readProcess) import System.Exit import System.IO import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad #ifndef mingw32_HOST_OS import qualified System.Posix.IO #else import Control.Applicative #endif import Data.Maybe import Utility.Misc import Utility.Exception type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) {- Normally, when reading from a process, it does not need to be fed any - standard input. -} readProcess :: FilePath -> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String readProcessEnv cmd args environ = readProcess' p where p = (proc cmd args) { std_out = CreatePipe , env = environ } readProcess' :: CreateProcess -> IO String readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do output <- hGetContentsStrict h hClose h return output {- Runs an action to write to a process on its stdin, - returns its output, and also allows specifying the environment. -} writeReadProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> (Maybe (Handle -> IO ())) -> (Maybe (Handle -> IO ())) -> IO String writeReadProcessEnv cmd args environ writestdin adjusthandle = do (Just inh, Just outh, _, pid) <- createProcess p maybe (return ()) (\a -> a inh) adjusthandle maybe (return ()) (\a -> a outh) adjusthandle -- fork off a thread to start consuming the output output <- hGetContents outh outMVar <- newEmptyMVar _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar () -- now write and flush any input maybe (return ()) (\a -> a inh >> hFlush inh) writestdin hClose inh -- done with stdin -- wait on the output takeMVar outMVar hClose outh -- wait on the process forceSuccessProcess p pid return output where p = (proc cmd args) { std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit , env = environ } {- Waits for a ProcessHandle, and throws an IOError if the process - did not exit successfully. -} forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () forceSuccessProcess p pid = do code <- waitForProcess pid case code of ExitSuccess -> return () ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n {- Waits for a ProcessHandle and returns True if it exited successfully. - Note that using this with createProcessChecked will throw away - the Bool, and is only useful to ignore the exit code of a process, - while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid return $ code == ExitSuccess ignoreFailureProcess :: ProcessHandle -> IO Bool ignoreFailureProcess pid = do void $ waitForProcess pid return True {- Runs createProcess, then an action on its handles, and then - forceSuccessProcess. -} createProcessSuccess :: CreateProcessRunner createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a {- Runs createProcess, then an action on its handles, and then - a checker action on its exit code, which must wait for the process. -} createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do t@(_, _, _, pid) <- createProcess p r <- tryNonAsync $ a t _ <- checker pid either E.throw return r {- Leaves the process running, suitable for lazy streaming. - Note: Zombies will result, and must be waited on. -} createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p {- Runs a process, optionally feeding it some input, and - returns a transcript combining its stdout and stderr, and - whether it succeeded or failed. -} processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) processTranscript cmd opts input = processTranscript' cmd opts Nothing input processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) processTranscript' cmd opts environ input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh , env = environ } hClose writeh get <- mkreader readh writeinput input p transcript <- get ok <- checkSuccessProcess pid return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe , env = environ } getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) writeinput input p transcript <- (++) <$> getout <*> geterr ok <- checkSuccessProcess pid return (transcript, ok) #endif where mkreader h = do s <- hGetContents h v <- newEmptyMVar void $ forkIO $ do void $ E.evaluate (length s) putMVar v () return $ do takeMVar v return s writeinput (Just s) p = do let inh = stdinHandle p unless (null s) $ do hPutStr inh s hFlush inh hClose inh writeinput Nothing _ = return () {- Runs a CreateProcessRunner, on a CreateProcess structure, that - is adjusted to pipe only from/to a single StdHandle, and passes - the resulting Handle to an action. -} withHandle :: StdHandle -> CreateProcessRunner -> CreateProcess -> (Handle -> IO a) -> IO a withHandle h creator p a = creator p' $ a . select where base = p { std_in = Inherit , std_out = Inherit , std_err = Inherit } (select, p') | h == StdinHandle = (stdinHandle, base { std_in = CreatePipe }) | h == StdoutHandle = (stdoutHandle, base { std_out = CreatePipe }) | h == StderrHandle = (stderrHandle, base { std_err = CreatePipe }) {- Like withHandle, but passes (stdin, stdout) handles to the action. -} withBothHandles :: CreateProcessRunner -> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a withBothHandles creator p a = creator p' $ a . bothHandles where p' = p { std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit } {- Forces the CreateProcessRunner to run quietly; - both stdout and stderr are discarded. -} withQuietOutput :: CreateProcessRunner -> CreateProcess -> IO () withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do let p' = p { std_out = UseHandle nullh , std_err = UseHandle nullh } creator p' $ const $ return () devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" #else devNull = "NUL" #endif {- Extract a desired handle from createProcess's tuple. - These partial functions are safe as long as createProcess is run - with appropriate parameters to set up the desired handle. - Get it wrong and the runtime crash will always happen, so should be - easily noticed. -} type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h stdinHandle _ = error "expected stdinHandle" stdoutHandle :: HandleExtractor stdoutHandle (_, Just h, _, _) = h stdoutHandle _ = error "expected stdoutHandle" stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) bothHandles (Just hin, Just hout, _, _) = (hin, hout) bothHandles _ = error "expected bothHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid {- Debugging trace for a CreateProcess. -} debugProcess :: CreateProcess -> IO () debugProcess p = do debugM "Utility.Process" $ unwords [ action ++ ":" , showCmd p ] where action | piped (std_in p) && piped (std_out p) = "chat" | piped (std_in p) = "feed" | piped (std_out p) = "read" | otherwise = "call" piped Inherit = False piped _ = True {- Shows the command that a CreateProcess will run. -} showCmd :: CreateProcess -> String showCmd = go . cmdspec where go (ShellCommand s) = s go (RawCommand c ps) = c ++ " " ++ show ps {- Starts an interactive process. Unlike runInteractiveProcess in - System.Process, stderr is inherited. -} startInteractiveProcess :: FilePath -> [String] -> Maybe [(String, String)] -> IO (ProcessHandle, Handle, Handle) startInteractiveProcess cmd args environ = do let p = (proc cmd args) { std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit , env = environ } (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) {- Wrapper around System.Process function that does debug logging. -} createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p System.Process.createProcess p