Merge branch 'threaded' into assistant

8 files changed, 89 insertions, 67 deletions

diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 9fa8d864f..d3b0c46ef 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -13,23 +13,25 @@ module Utility.CoProcess (
 	query
 ) where
 
-import System.Cmd.Utils
+import System.Process
 
 import Common
 
-type CoProcessHandle = (PipeHandle, Handle, Handle)
+type CoProcessHandle = (ProcessHandle, Handle, Handle, FilePath, [String])
 
 start :: FilePath -> [String] -> IO CoProcessHandle
-start command params = hPipeBoth command params
+start command params = do
+	(from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing
+	return (pid, to, from, command, params)
 
 stop :: CoProcessHandle -> IO ()
-stop (pid, from, to) = do
+stop (pid, from, to, command, params) = do
 	hClose to
 	hClose from
-	forceSuccess pid
+	forceSuccessProcess pid command params
 
 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 e13afe5d4..26ac688e3 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -11,9 +11,9 @@ import qualified Data.ByteString.Lazy as L
 import System.Posix.Types
 import Control.Applicative
 import Control.Concurrent
-import Control.Exception (finally, bracket)
-import System.Exit
+import Control.Exception (bracket)
 import System.Posix.Env (setEnv, unsetEnv, getEnv)	
+import System.Process
 
 import Common
 
@@ -39,18 +39,30 @@ stdParams params = do
 readStrict :: [CommandParam] -> IO String
 readStrict params = do
 	params' <- stdParams params
-	pOpen ReadFromPipe "gpg" params' hGetContentsStrict
+	(_, Just from, _, pid)
+		<- createProcess (proc "gpg" params')
+			{ std_out = CreatePipe }
+	hSetBinaryMode from True
+	r <- hGetContentsStrict from
+	forceSuccessProcess pid "gpg" params'
+	return r
 
 {- 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
-	(pid, fromh, toh) <- hPipeBoth "gpg" params'
-	_ <- forkIO $ finally (hPutStr toh input) (hClose toh)
-	output <- hGetContentsStrict fromh
-	forceSuccess pid
-	return output
+	(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
 
 {- Runs gpg with some parameters, first feeding it a passphrase via
  - --passphrase-fd, then feeding it an input, and passing a handle
@@ -70,17 +82,14 @@ passphraseHandle params passphrase a b = do
 	let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
 
 	params' <- stdParams $ passphrasefd ++ params
-	(pid, fromh, toh) <- hPipeBoth "gpg" params'
-	pid2 <- forkProcess $ do
-		L.hPut toh =<< a
-		hClose toh
-		exitSuccess
+	(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
-	forceSuccess pid
-	_ <- getProcessStatus True False pid2
+	forceSuccessProcess pid "gpg" params'
 	closeFd frompipe
 	return ret
 
diff --git a/Utility/INotify.hs b/Utility/INotify.hs
index bf87f4e71..55233ef76 100644
--- a/Utility/INotify.hs
+++ b/Utility/INotify.hs
@@ -10,6 +10,7 @@ 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
@@ -160,12 +161,9 @@ tooManyWatches hook dir = do
 
 querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
 querySysctl ps = do
-	v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps
+	v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps) []
 	case v of
 		Nothing -> return Nothing
-		Just (pid, h) -> do
-			val <- parsesysctl <$> hGetContentsStrict h
-			void $ getProcessStatus True False $ processID pid
-			return val
+		Just s -> return $ parsesysctl s
 	where
 		parsesysctl s = readish =<< lastMaybe (words s)
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index 0061dfe57..ebd273b2e 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -12,6 +12,7 @@ module Utility.Lsof where
 import Common
 
 import System.Posix.Types
+import System.Process
 
 data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown
 	deriving (Show, Eq)
@@ -34,10 +35,8 @@ queryDir path = query ["+d", path]
  -}
 query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
 query opts = do
-	(pid, s) <- pipeFrom "lsof" ("-F0can" : opts)
-	let !r = parse s
-	void $ getProcessStatus True False $ processID pid
-	return r
+	(_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) []
+	return $ parse s
 
 {- Parsing null-delimited output like:
  -
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 3b359139b..e11586467 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -33,7 +33,7 @@ separate c l = unbreak $ break c l
 			| otherwise = (a, tail b)
 
 {- Breaks out the first line. -}
-firstLine :: String-> String
+firstLine :: String -> String
 firstLine = takeWhile (/= '\n')
 
 {- Splits a list into segments that are delimited by items matching
diff --git a/Utility/Process.hs b/Utility/Process.hs
new file mode 100644
index 000000000..9f79efa81
--- /dev/null
+++ b/Utility/Process.hs
@@ -0,0 +1,40 @@
+{- System.Process enhancements
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Process where
+
+import System.Process
+import System.Exit
+import System.IO
+
+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
+
+{- 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
+			, env = environ
+			}
+	output  <- hGetContentsStrict h
+	hClose h
+	forceSuccessProcess pid cmd args
+	return output
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index aedf27137..47280a40b 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -1,6 +1,6 @@
 {- safely running shell commands
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -8,11 +8,8 @@
 module Utility.SafeCommand where
 
 import System.Exit
-import qualified System.Posix.Process
-import System.Posix.Process hiding (executeFile)
-import System.Posix.Signals
+import System.Process
 import Data.String.Utils
-import System.Log.Logger
 import Control.Applicative
 
 {- A type for parameters passed to a shell command. A command can
@@ -42,7 +39,7 @@ boolSystem :: FilePath -> [CommandParam] -> IO Bool
 boolSystem command params = boolSystemEnv command params Nothing
 
 boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
-boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env
+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
 	where
 		dispatch ExitSuccess = True
 		dispatch _ = False
@@ -51,36 +48,13 @@ boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env
 safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
 safeSystem command params = safeSystemEnv command params Nothing
 
-{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -}
+{- Unlike many implementations of system, SIGINT(ctrl-c) is allowed
+ - to propigate and will terminate the program. -}
 safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
-safeSystemEnv command params env = do
-	-- Going low-level because all the high-level system functions
-	-- block SIGINT etc. We need to block SIGCHLD, but allow
-	-- SIGINT to do its default program termination.
-	let sigset = addSignal sigCHLD emptySignalSet
-	oldint <- installHandler sigINT Default Nothing
-	oldset <- getSignalMask
-	blockSignals sigset
-	childpid <- forkProcess $ childaction oldint oldset
-	mps <- getProcessStatus True False childpid
-	restoresignals oldint oldset
-	case mps of
-		Just (Exited code) -> return code
-		_ -> error $ "unknown error running " ++ command
-	where
-		restoresignals oldint oldset = do
-			_ <- installHandler sigINT oldint Nothing
-			setSignalMask oldset
-		childaction oldint oldset = do
-			restoresignals oldint oldset
-			executeFile command True (toCommand params) env
-
-{- executeFile with debug logging -}
-executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
-executeFile c path p e = do
-	debugM "Utility.SafeCommand.executeFile" $
-		"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
-	System.Posix.Process.executeFile c path p e
+safeSystemEnv command params environ = do
+	(_, _, _, pid) <- createProcess (proc command $ toCommand params)
+		{ env = environ }
+	waitForProcess pid
 
 {- Escapes a filename or other parameter to be safely able to be exposed to
  - the shell. -}
diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs
index 4dcbf1cca..62e0fc859 100644
--- a/Utility/TempFile.hs
+++ b/Utility/TempFile.hs
@@ -9,7 +9,7 @@ module Utility.TempFile where
 
 import Control.Exception (bracket)
 import System.IO
-import System.Posix.Process hiding (executeFile)
+import System.Posix.Process
 import System.Directory
 
 import Utility.Exception