From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- Utility/Process.hs | 364 ----------------------------------------------------- 1 file changed, 364 deletions(-) delete mode 100644 Utility/Process.hs (limited to 'Utility/Process.hs') diff --git a/Utility/Process.hs b/Utility/Process.hs deleted file mode 100644 index 549ae570..00000000 --- a/Utility/Process.hs +++ /dev/null @@ -1,364 +0,0 @@ -{- 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, - readProcessEnv, - writeReadProcessEnv, - forceSuccessProcess, - checkSuccessProcess, - ignoreFailureProcess, - createProcessSuccess, - createProcessChecked, - createBackgroundProcess, - processTranscript, - processTranscript', - withHandle, - withBothHandles, - withQuietOutput, - createProcess, - startInteractiveProcess, - stdinHandle, - stdoutHandle, - stderrHandle, - processHandle, - devNull, -) where - -import qualified System.Process -import 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 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 = - withHandle StdoutHandle createProcessSuccess p $ \h -> do - output <- hGetContentsStrict h - hClose h - return output - where - p = (proc cmd args) - { std_out = CreatePipe - , env = environ - } - -{- 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) -#ifndef mingw32_HOST_OS -{- This implementation interleves stdout and stderr in exactly the order - - the process writes them. -} -processTranscript' cmd opts environ input = do - (readf, writef) <- createPipe - readh <- fdToHandle readf - writeh <- 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 - - -- now write and flush any input - case input of - Just s -> do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - Nothing -> return () - - transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) -#else -{- This implementation for Windows puts stderr after stdout. -} -processTranscript' cmd opts environ input = do - 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) - - case input of - Just s -> do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - Nothing -> return () - - 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 - -{- 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 -- cgit v1.2.3