diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/CoProcess.hs | 12 | ||||
| -rw-r--r-- | Utility/Gpg.hs | 45 | ||||
| -rw-r--r-- | Utility/INotify.hs | 1 | ||||
| -rw-r--r-- | Utility/Lsof.hs | 9 | ||||
| -rw-r--r-- | Utility/Process.hs | 200 | ||||
| -rw-r--r-- | Utility/SafeCommand.hs | 3 |
6 files changed, 209 insertions, 61 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index d3b0c46ef..67f861bb3 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,25 +13,23 @@ module Utility.CoProcess ( query ) where -import System.Process - import Common -type CoProcessHandle = (ProcessHandle, Handle, Handle, FilePath, [String]) +type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess) start :: FilePath -> [String] -> IO CoProcessHandle start command params = do (from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing - return (pid, to, from, command, params) + return (pid, to, from, proc command params) stop :: CoProcessHandle -> IO () -stop (pid, from, to, command, params) = do +stop (pid, from, to, p) = do hClose to hClose from - forceSuccessProcess pid command params + forceSuccessProcess p pid query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b -query (_, from, to, _, _) send receive = do +query (_, from, to, _) send receive = do _ <- send to hFlush to receive from diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 26ac688e3..eed77805c 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -13,7 +13,6 @@ import Control.Applicative import Control.Concurrent import Control.Exception (bracket) import System.Posix.Env (setEnv, unsetEnv, getEnv) -import System.Process import Common @@ -39,30 +38,21 @@ stdParams params = do readStrict :: [CommandParam] -> IO String readStrict params = do params' <- stdParams params - (_, Just from, _, pid) - <- createProcess (proc "gpg" params') - { std_out = CreatePipe } - hSetBinaryMode from True - r <- hGetContentsStrict from - forceSuccessProcess pid "gpg" params' - return r + withHandle StdoutHandle createProcessSuccess (proc "gpg" params') $ \h -> do + hSetBinaryMode h True + hGetContentsStrict h {- Runs gpg, piping an input value to it, and returning its stdout, - strictly. -} pipeStrict :: [CommandParam] -> String -> IO String pipeStrict params input = do params' <- stdParams params - (Just to, Just from, _, pid) - <- createProcess (proc "gpg" params') - { std_in = CreatePipe - , std_out = CreatePipe } - hSetBinaryMode to True - hSetBinaryMode from True - hPutStr to input - hClose to - r <- hGetContentsStrict from - forceSuccessProcess pid "gpg" params' - return r + withBothHandles createProcessSuccess (proc "gpg" params') $ \(to, from) -> do + hSetBinaryMode to True + hSetBinaryMode from True + hPutStr to input + hClose to + hGetContentsStrict from {- Runs gpg with some parameters, first feeding it a passphrase via - --passphrase-fd, then feeding it an input, and passing a handle @@ -82,16 +72,13 @@ passphraseHandle params passphrase a b = do let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] params' <- stdParams $ passphrasefd ++ params - (Just toh, Just fromh, _, pid) <- createProcess (proc "gpg" params') - { std_in = CreatePipe, std_out = CreatePipe } - L.hPut toh =<< a - hClose toh - ret <- b fromh - - -- cleanup - forceSuccessProcess pid "gpg" params' - closeFd frompipe - return ret + closeFd frompipe `after` + withBothHandles createProcessSuccess (proc "gpg" params') go + where + go (to, from) = do + L.hPut to =<< a + hClose to + b from {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name. -} diff --git a/Utility/INotify.hs b/Utility/INotify.hs index 55233ef76..66c0ab23d 100644 --- a/Utility/INotify.hs +++ b/Utility/INotify.hs @@ -10,7 +10,6 @@ module Utility.INotify where import Common hiding (isDirectory) import Utility.ThreadLock import Utility.Types.DirWatcher -import System.Process import System.INotify import qualified System.Posix.Files as Files diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index ebd273b2e..ce6a16283 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -12,7 +12,6 @@ module Utility.Lsof where import Common import System.Posix.Types -import System.Process data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown deriving (Show, Eq) @@ -34,9 +33,11 @@ queryDir path = query ["+d", path] - Note: If lsof is not available, this always returns [] ! -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] -query opts = do - (_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) [] - return $ parse s +query opts = + withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do + parse <$> hGetContentsStrict h + where + p = proc "lsof" ("-F0can" : opts) {- Parsing null-delimited output like: - diff --git a/Utility/Process.hs b/Utility/Process.hs index 9f79efa81..9b57c3b7a 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,40 +1,202 @@ -{- System.Process enhancements +{- System.Process enhancements, including additional ways of running + - processes, and logging. - - Copyright 2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -module Utility.Process where +{-# LANGUAGE Rank2Types #-} -import System.Process +module Utility.Process ( + module X, + CreateProcess, + StdHandle(..), + readProcessEnv, + forceSuccessProcess, + checkSuccessProcess, + createProcessSuccess, + createProcessChecked, + createBackgroundProcess, + withHandle, + withBothHandles, + createProcess, + runInteractiveProcess, + readProcess +) 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, runInteractiveProcess, readProcess, readProcessWithExitCode) import System.Exit import System.IO +import System.Log.Logger import Utility.Misc +type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a + +data StdHandle = StdinHandle | StdoutHandle | StderrHandle + deriving (Eq) + +{- Like readProcess, but allows specifying the environment, and does + - not mess with stdin. -} +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 + } + {- Waits for a ProcessHandle, and throws an exception if the process - did not exit successfully. -} -forceSuccessProcess :: ProcessHandle -> String -> [String] -> IO () -forceSuccessProcess pid cmd args = do +forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () +forceSuccessProcess p pid = do code <- waitForProcess pid case code of ExitSuccess -> return () - ExitFailure n -> error $ - cmd ++ " " ++ show args ++ " exited " ++ show n + ExitFailure n -> error $ showCmd p ++ " exited " ++ show n -{- Like readProcess, but allows specifying the environment, and does - - not mess with stdin. -} -readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String -readProcessEnv cmd args environ = do - (_, Just h, _, pid) - <- createProcess (proc cmd args) - { std_in = Inherit +{- Waits for a ProcessHandle and returns True if it exited successfully. -} +checkSuccessProcess :: ProcessHandle -> IO Bool +checkSuccessProcess pid = do + code <- waitForProcess pid + return $ code == ExitSuccess + +{- 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 + - an action on its exit code. -} +createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner +createProcessChecked checker p a = do + t@(_, _, _, pid) <- createProcess p + r <- a t + _ <- checker pid + 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 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 - , env = environ } - output <- hGetContentsStrict h - hClose h - forceSuccessProcess pid cmd args - return output + +{- 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" + +{- Debugging trace for a CreateProcess. -} +debugProcess :: CreateProcess -> IO () +debugProcess p = do + debugM "Utility.Process" $ unwords + [ action ++ ":" + , showCmd p + , maybe "" show (env 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 + +{- Wrappers for System.Process functions that do debug logging. + - + - More could be added, but these are the only ones I usually need. + -} + +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + debugProcess p + System.Process.createProcess p + +runInteractiveProcess + :: FilePath + -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> IO (Handle, Handle, Handle, ProcessHandle) +runInteractiveProcess f args c e = do + debugProcess $ (proc f args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + System.Process.runInteractiveProcess f args c e + +readProcess + :: FilePath + -> [String] + -> String + -> IO String +readProcess f args input = do + debugProcess $ (proc f args) { std_out = CreatePipe } + System.Process.readProcess f args input diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 47280a40b..19dd707b8 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -8,7 +8,8 @@ module Utility.SafeCommand where import System.Exit -import System.Process +import Utility.Process +import System.Process (env) import Data.String.Utils import Control.Applicative |