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:
parent
549f861999
commit
1db7d27a45
17 changed files with 251 additions and 126 deletions
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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:
|
||||
-
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue