add back debug logging

Make Utility.Process wrap the parts of System.Process that I use,
and add debug logging to them.

Also wrote some higher-level code that allows running an action
with handles to a processes stdin or stdout (or both), and checking
its exit status, all in a single function call.

As a bonus, the debug logging now indicates whether the process
is being run to read from it, feed it data, chat with it (writing and
reading), or just call it for its side effect.
This commit is contained in:
Joey Hess 2012-07-19 00:43:36 -04:00
parent 549f861999
commit 1db7d27a45
17 changed files with 251 additions and 126 deletions

View file

@ -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

View file

@ -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. -}

View file

@ -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

View file

@ -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:
-

View file

@ -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
{- 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
code <- waitForProcess pid
case code of
ExitSuccess -> return ()
ExitFailure n -> error $
cmd ++ " " ++ show args ++ " exited " ++ show n
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 = do
(_, Just h, _, pid)
<- createProcess (proc cmd args)
{ std_in = Inherit
, std_out = CreatePipe
, std_err = Inherit
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
}
output <- hGetContentsStrict h
hClose h
forceSuccessProcess pid cmd args
return output
{- Waits for a ProcessHandle, and throws an exception 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 -> error $ showCmd p ++ " exited " ++ show n
{- 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
}
{- 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

View file

@ -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