switch from System.Cmd.Utils to System.Process

Test suite now passes with -threaded!

I traced back all the hangs with -threaded to System.Cmd.Utils. It seems
it's just crappy/unsafe/outdated, and should not be used. System.Process
seems to be the cool new thing, so converted all the code to use it
instead.

In the process, --debug stopped printing commands it runs. I may try to
bring that back later.

Note that even SafeSystem was switched to use System.Process. Since that
was a modified version of code from System.Cmd.Utils, it needed to be
converted too. I also got rid of nearly all calls to forkProcess,
and all calls to executeFile, which I'm also doubtful about working
well with -threaded.

Annex/Branch.hs

@@ -164,9 +164,7 @@ get' staleok file = fromcache =<< getCache file
 		fromjournal Nothing
 			| staleok = withIndex frombranch
 			| otherwise = withIndexUpdate $ frombranch >>= cache
-		frombranch = do
+		frombranch = L.unpack <$> catFile fullname file
-			liftIO $ putStrLn $ "frombranch " ++ file
-			L.unpack <$> catFile fullname file
 		cache content = do
 			setCache file content
 			return content

Annex/UUID.hs

@@ -20,6 +20,8 @@ module Annex.UUID (
 	removeRepoUUID,
 ) where
 
+import System.Process
+
 import Common.Annex
 import qualified Git
 import qualified Git.Config
@@ -32,8 +34,10 @@ configkey = annexConfig "uuid"
 {- Generates a UUID. There is a library for this, but it's not packaged,
  - so use the command line tool. -}
 genUUID :: IO UUID
-genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine
+genUUID = gen . lines <$> readProcess command params []
 	where
+		gen [] = error $ "no output from " ++ command
+		gen (l:_) = toUUID l
 		command = SysConfig.uuid
 		params
 			-- request a random uuid be generated

Backend/SHA.hs

@@ -12,6 +12,7 @@ import qualified Annex
 import Types.Backend
 import Types.Key
 import Types.KeySource
+import System.Process
 
 import qualified Build.SysConfig as SysConfig
 import Data.Digest.Pure.SHA
@@ -53,14 +54,16 @@ shaN shasize file filesize = do
 	showAction "checksum"
 	case shaCommand shasize filesize of
 		Left sha -> liftIO $ sha <$> L.readFile file
-		Right command -> liftIO $ runcommand command
+		Right command -> liftIO $ parse command . lines <$>
+			readProcess command (toCommand [File file]) ""
 	where
-		runcommand command =
+		parse command [] = bad command
-			pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do
+		parse command (l:_)
-				sha <- fst . separate (== ' ') <$> hGetLine h
+			| null sha = bad command
-				if null sha
+			| otherwise = sha
-					then error $ command ++ " parse error"
+			where
-					else return sha
+				sha = fst $ separate (== ' ') l
+		bad command = error $ command ++ " parse error"
 
 shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String
 shaCommand shasize filesize

Build/Configure.hs

@@ -4,7 +4,7 @@ module Build.Configure where
 
 import System.Directory
 import Data.List
-import System.Cmd.Utils
+import System.Process
 import Control.Applicative
 import System.FilePath
 
@@ -71,7 +71,7 @@ getVersionString = do
 
 getGitVersion :: Test
 getGitVersion = do
-	(_, s) <- pipeFrom "git" ["--version"]
+	s <- readProcess "git" ["--version"] ""
 	let version = unwords $ drop 2 $ words $ head $ lines s
 	return $ Config "gitversion" (StringConfig version)
 

Command/Fsck.hs

@@ -7,6 +7,8 @@
 
 module Command.Fsck where
 
+import System.Posix.Process (getProcessID)
+
 import Common.Annex
 import Command
 import qualified Annex

Command/Map.hs

@@ -9,6 +9,7 @@ module Command.Map where
 
 import Control.Exception.Extensible
 import qualified Data.Map as M
+import System.Process
 
 import Common.Annex
 import Command
@@ -198,9 +199,13 @@ tryScan r
 			case result of
 				Left _ -> return Nothing
 				Right r' -> return $ Just r'
-		pipedconfig cmd params = safely $
+		pipedconfig cmd params = safely $ do
-			pOpen ReadFromPipe cmd (toCommand params) $
+			(_, Just h, _, pid) <-
-				Git.Config.hRead r
+				createProcess (proc cmd $ toCommand params)
+					{ std_out = CreatePipe }
+			r' <- Git.Config.hRead r h
+			forceSuccessProcess pid cmd $ toCommand params
+			return r'
 
 		configlist =
 			onRemote r (pipedconfig, Nothing) "configlist" [] []

Common.hs

@@ -13,16 +13,15 @@ import Data.String.Utils as X
 import System.Path as X
 import System.FilePath as X
 import System.Directory as X
-import System.Cmd.Utils as X hiding (safeSystem)
 import System.IO as X hiding (FilePath)
 import System.Posix.Files as X
 import System.Posix.IO as X
-import System.Posix.Process as X hiding (executeFile)
 import System.Exit as X
 
 import Utility.Misc as X
 import Utility.Exception as X
 import Utility.SafeCommand as X
+import Utility.Process as X
 import Utility.Path as X
 import Utility.Directory as X
 import Utility.Monad as X

Config.hs

@@ -7,6 +7,8 @@
 
 module Config where
 
+import System.Process
+
 import Common.Annex
 import qualified Git
 import qualified Git.Config
@@ -56,7 +58,7 @@ remoteCost r def = do
 	cmd <- getRemoteConfig r "cost-command" ""
 	(fromMaybe def . readish) <$>
 		if not $ null cmd
-			then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd]
+			then liftIO $ readProcess "sh" ["-c", cmd] ""
 			else getRemoteConfig r "cost" ""
 
 cheapRemoteCost :: Int
@@ -116,4 +118,4 @@ getHttpHeaders = do
 	cmd <- getConfig (annexConfig "http-headers-command") ""
 	if null cmd
 		then fromRepo $ Git.Config.getList "annex.http-headers"
-		else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd])
+		else lines <$> liftIO (readProcess "sh" ["-c", cmd] "")

Git/Branch.hs

@@ -76,9 +76,7 @@ commit message branch parentrefs repo = do
 	sha <- getSha "commit-tree" $ pipeWriteRead
 		(map Param $ ["commit-tree", show tree] ++ ps)
 		message repo
-	print ("got", sha)
 	run "update-ref" [Param $ show branch, Param $ show sha] repo
-	print ("update-ref done", sha)
 	return sha
 	where
 		ps = concatMap (\r -> ["-p", show r]) parentrefs

Git/CatFile.hs

@@ -50,16 +50,11 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
 catObjectDetails h object = CoProcess.query h send receive
 	where
 		send to = do
-			putStrLn "catObjectDetails send start"
 			fileEncoding to
 			hPutStrLn to $ show object
-			putStrLn $ "catObjectDetails send done " ++ show object
 		receive from = do
-			putStrLn "catObjectDetails read header start"
 			fileEncoding from
-			putStrLn "catObjectDetails read header start2"
 			header <- hGetLine from
-			putStrLn "catObjectDetails read header done"
 			case words header of
 				[sha, objtype, size]
 					| length sha == shaSize &&
@@ -72,14 +67,9 @@ catObjectDetails h object = CoProcess.query h send receive
 					| header == show object ++ " missing" -> dne
 					| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
 		readcontent bytes from sha = do
-			putStrLn "readcontent start"
 			content <- S.hGet from bytes
-			putStrLn "readcontent end"
 			c <- hGetChar from
-			putStrLn "readcontent newline read"
 			when (c /= '\n') $
 				error "missing newline from git cat-file"
 			return $ Just (L.fromChunks [content], Ref sha)
-		dne = do
+		dne = return Nothing
-			putStrLn "dne"
-			return Nothing

Git/CheckAttr.hs

@@ -44,15 +44,11 @@ checkAttr (h, attrs, cwd) want file = do
 		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
 	where
 		send to = do
-			putStrLn "checkAttr send start"
 			fileEncoding to
 			hPutStr to $ file' ++ "\0"
-			putStrLn "checkAttr send end"
 		receive from = forM attrs $ \attr -> do
-			putStrLn "checkAttr receive start"
 			fileEncoding from
 			l <- hGetLine from
-			putStrLn "checkAttr receive end"
 			return (attr, attrvalue attr l)
 		{- Before git 1.7.7, git check-attr worked best with
 		 - absolute filenames; using them worked around some bugs

Git/Command.hs

@@ -7,10 +7,8 @@
 
 module Git.Command where
 
-import qualified Data.Text.Lazy as L
+import System.Process
-import qualified Data.Text.Lazy.IO as L
+import System.Posix.Process (getAnyProcessStatus)
-import Control.Concurrent
-import Control.Exception (finally)
 
 import Common
 import Git
@@ -44,31 +42,18 @@ run subcommand params repo = assertLocal repo $
  -}
 pipeRead :: [CommandParam] -> Repo -> IO String
 pipeRead params repo = assertLocal repo $ do
-	(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo
+	(_, Just h, _, _) <- createProcess
+		(proc "git" $ toCommand $ gitCommandLine params repo)
+			{ std_out = CreatePipe }
 	fileEncoding h
 	hGetContents h
 
-{- Runs a git subcommand, feeding it input.
- - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
-pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle
-pipeWrite params s repo = assertLocal repo $ do
-	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
-	L.hPutStr h s
-	hClose h
-	return p
-
 {- Runs a git subcommand, feeding it input, and returning its output,
  - which is expected to be fairly small, since it's all read into memory
  - strictly. -}
 pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String
-pipeWriteRead params s repo = assertLocal repo $ do
+pipeWriteRead params s repo = assertLocal repo $
-	(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
+	readProcess "git" (toCommand $ gitCommandLine params repo) s
-	fileEncoding to
-	fileEncoding from
-	_ <- forkIO $ finally (hPutStr to s) (hClose to)
-	c <- hGetContentsStrict from
-	forceSuccess p
-	return c
 
 {- Reads null terminated output of a git command (as enabled by the -z 
  - parameter), and splits it. -}

Git/Config.hs

@@ -9,6 +9,7 @@ module Git.Config where
 
 import qualified Data.Map as M
 import Data.Char
+import System.Process
 
 import Common
 import Git
@@ -39,7 +40,7 @@ reRead :: Repo -> IO Repo
 reRead = read'
 
 {- Cannot use pipeRead because it relies on the config having been already
- - read. Instead, chdir to the repo.
+ - read. Instead, chdir to the repo and run git config.
  -}
 read' :: Repo -> IO Repo
 read' repo = go repo
@@ -47,9 +48,14 @@ read' repo = go repo
 		go Repo { location = Local { gitdir = d } } = git_config d
 		go Repo { location = LocalUnknown d } = git_config d
 		go _ = assertLocal repo $ error "internal"
-		git_config d = bracketCd d $
+		git_config d = do
-			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
+			(_, Just h, _, pid)
-				hRead repo
+				<- createProcess (proc "git" params)
+					{ std_out = CreatePipe, cwd = Just d }
+			repo' <- hRead repo h
+			forceSuccessProcess pid "git" params
+			return repo'
+		params = ["config", "--null", "--list"]
 
 {- Reads git config from a handle and populates a repo with it. -}
 hRead :: Repo -> Handle -> IO Repo

Git/Queue.hs

@@ -19,7 +19,7 @@ module Git.Queue (
 
 import qualified Data.Map as M
 import System.IO
-import System.Cmd.Utils
+import System.Process
 import Data.String.Utils
 
 import Utility.SafeCommand
@@ -148,11 +148,14 @@ runAction :: Repo -> Action -> IO ()
 runAction repo (UpdateIndexAction streamers) =
 	-- list is stored in reverse order
 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
-runAction repo action@(CommandAction {}) =
+runAction repo action@(CommandAction {}) = do
-	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
+	(Just h, _, _, pid) <- createProcess (proc "xargs" params)
+		{ std_in = CreatePipe }
+	fileEncoding h
+	hPutStr h $ join "\0" $ getFiles action
+	hClose h
+	forceSuccessProcess pid "xargs" params
 	where
-		params = toCommand $ gitCommandLine
+		params = "-0":"git":baseparams
+		baseparams = toCommand $ gitCommandLine
 			(Param (getSubcommand action):getParams action) repo
-		feedxargs h = do
-			fileEncoding h
-			hPutStr h $ join "\0" $ getFiles action

Git/Ref.hs

@@ -40,10 +40,7 @@ exists ref = runBool "show-ref"
 
 {- Get the sha of a fully qualified git ref, if it exists. -}
 sha :: Branch -> Repo -> IO (Maybe Sha)
-sha branch repo = do
+sha branch repo = process <$> showref repo
-	r <- process <$> showref repo
-	print r
-	return r
 	where
 		showref = pipeRead [Param "show-ref",
 			Param "--hash", -- get the hash

Git/UpdateIndex.hs

@@ -17,7 +17,7 @@ module Git.UpdateIndex (
 	stageSymlink
 ) where
 
-import System.Cmd.Utils
+import System.Process
 
 import Common
 import Git
@@ -37,12 +37,13 @@ pureStreamer !s = \streamer -> streamer s
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
 streamUpdateIndex repo as = do
-	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
+	(Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
 	fileEncoding h
 	forM_ as (stream h)
 	hClose h
-	forceSuccess p
+	forceSuccessProcess p "git" ps
 	where
+		ps = toCommand $ gitCommandLine params repo
 		params = map Param ["update-index", "-z", "--index-info"]
 		stream h a = a (streamer h)
 		streamer h s = do

Remote/Bup.hs

@@ -136,9 +136,11 @@ retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
 retrieveEncrypted buprepo (cipher, enck) _ f = do
 	let params = bupParams "join" buprepo [Param $ bupRef enck]
 	liftIO $ catchBoolIO $ do
-		(pid, h) <- hPipeFrom "bup" $ toCommand params
+		(_, Just h, _, pid)
+			<- createProcess (proc "bup" $ toCommand params)
+				{ std_out = CreatePipe }
 		withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
-		forceSuccess pid
+		forceSuccessProcess pid "bup" $ toCommand params
 		return True
 
 remove :: Key -> Annex Bool

Remote/Git.hs

@@ -9,6 +9,7 @@ module Remote.Git (remote, repoAvail) where
 
 import qualified Data.Map as M
 import Control.Exception.Extensible
+import System.Process
 
 import Common.Annex
 import Utility.CopyFile
@@ -126,17 +127,20 @@ tryGitConfigRead r
 		safely a = either (const $ return r) return
 				=<< liftIO (try a :: IO (Either SomeException Git.Repo))
 
-		pipedconfig cmd params = safely $
+		pipedconfig cmd params = safely $ do
-			pOpen ReadFromPipe cmd (toCommand params) $
+			(_, Just h, _, pid) <-
-				Git.Config.hRead r
+				createProcess (proc cmd $ toCommand params)
+					{ std_out = CreatePipe }
+			r' <- Git.Config.hRead r h
+			forceSuccessProcess pid cmd $ toCommand params
+			return r'
 
 		geturlconfig headers = do
 			s <- Url.get (Git.repoLocation r ++ "/config") headers
 			withTempFile "git-annex.tmp" $ \tmpfile h -> do
 				hPutStr h s
 				hClose h
-				pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $
+				pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
-					Git.Config.hRead r
 
 		store = observe $ \r' -> do
 			g <- gitRepo

Remote/Hook.hs

@@ -9,7 +9,6 @@ module Remote.Hook (remote) where
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
-import System.Exit
 import System.Environment
 
 import Common.Annex
@@ -136,17 +135,5 @@ checkPresent r h k = do
 		findkey s = show k `elem` lines s
 		check Nothing = error "checkpresent hook misconfigured"
 		check (Just hook) = do
-			(frompipe, topipe) <- createPipe
+			env <- hookEnv k Nothing
-			pid <- forkProcess $ do
+			findkey <$> readProcessEnv "sh" ["-c", hook] env
-				_ <- dupTo topipe stdOutput
-				closeFd frompipe
-				executeFile "sh" True ["-c", hook]
-					=<< hookEnv k Nothing
-			closeFd topipe
-			fromh <- fdToHandle frompipe
-			reply <- hGetContentsStrict fromh
-			hClose fromh
-			s <- getProcessStatus True False pid
-			case s of
-				Just (Exited ExitSuccess) -> return $ findkey reply
-				_ -> error "checkpresent hook failed"

Remote/Rsync.hs

@@ -9,6 +9,7 @@ module Remote.Rsync (remote) where
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
+import System.Posix.Process (getProcessID)
 
 import Common.Annex
 import Types.Remote

System/Cmd/Utils.hs

@@ -1,568 +0,0 @@
--- arch-tag: Command utilities main file
-{-# LANGUAGE CPP #-}
-{-
-Copyright (C) 2004-2006 John Goerzen <jgoerzen@complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--}
-
-{- |
-   Module     : System.Cmd.Utils
-   Copyright  : Copyright (C) 2004-2006 John Goerzen
-   License    : GNU GPL, version 2 or above
-
-   Maintainer : John Goerzen <jgoerzen@complete.org>
-   Stability  : provisional
-   Portability: portable to platforms with POSIX process\/signal tools
-
-Command invocation utilities.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Please note: Most of this module is not compatible with Hugs.
-
-Command lines executed will be logged using "System.Log.Logger" at the
-DEBUG level.  Failure messages will be logged at the WARNING level in addition
-to being raised as an exception.  Both are logged under
-\"System.Cmd.Utils.funcname\" -- for instance,
-\"System.Cmd.Utils.safeSystem\".  If you wish to suppress these messages
-globally, you can simply run:
-
-> updateGlobalLogger "System.Cmd.Utils.safeSystem"
->                     (setLevel CRITICAL)
-
-See also: 'System.Log.Logger.updateGlobalLogger',
-"System.Log.Logger".
-
-It is possible to set up pipelines with these utilities.  Example:
-
-> (pid1, x1) <- pipeFrom "ls" ["/etc"]
-> (pid2, x2) <- pipeBoth "grep" ["x"] x1
-> putStr x2
-> ... the grep output is displayed ...
-> forceSuccess pid2
-> forceSuccess pid1
-
-Remember, when you use the functions that return a String, you must not call
-'forceSuccess' until after all data from the String has been consumed.  Failure
-to wait will cause your program to appear to hang.
-
-Here is an example of the wrong way to do it:
-
-> (pid, x) <- pipeFrom "ls" ["/etc"]
-> forceSuccess pid         -- Hangs; the called program hasn't terminated yet
-> processTheData x
-
-You must instead process the data before calling 'forceSuccess'.
-
-When using the hPipe family of functions, this is probably more obvious.
-
-Most of this module will be incompatible with Windows.
--}
-
-
-module System.Cmd.Utils(-- * High-Level Tools
-                    PipeHandle(..),
-                    safeSystem,
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-                    forceSuccess,
-#ifndef __HUGS__
-                    posixRawSystem,
-                    forkRawSystem,
-                    -- ** Piping with lazy strings
-                    pipeFrom,
-                    pipeLinesFrom,
-                    pipeTo,
-                    pipeBoth,
-                    -- ** Piping with handles
-                    hPipeFrom,
-                    hPipeTo,
-                    hPipeBoth,
-#endif
-#endif
-                    -- * Low-Level Tools
-                    PipeMode(..),
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-                    pOpen, pOpen3, pOpen3Raw
-#endif
-#endif
-                   )
-where
-
--- FIXME - largely obsoleted by 6.4 - convert to wrappers.
-
-import System.Exit
-import System.Cmd
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.Posix.IO
-import System.Posix.Process
-import System.Posix.Signals
-import qualified System.Posix.Signals
-#endif
-import System.Posix.Types
-import System.IO
-import System.IO.Error
-import Control.Concurrent(forkIO)
-import Control.Exception(finally)
-
-data PipeMode = ReadFromPipe | WriteToPipe
-
-logbase :: String
-logbase = "System.Cmd.Utils"
-
-{- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or
-'pipeBoth'.  Contains both a ProcessID and the original command that was
-executed.  If you prefer not to use 'forceSuccess' on the result of one
-of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle',
-as a parameter to 'System.Posix.Process.getProcessStatus'. -}
-data PipeHandle =
-    PipeHandle { processID :: ProcessID,
-                 phCommand :: FilePath,
-                 phArgs :: [String],
-                 phCreator :: String -- ^ Function that created it
-               }
-    deriving (Eq, Show)
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like 'pipeFrom', but returns data in lines instead of just a String.
-Shortcut for calling lines on the result from 'pipeFrom'.
-
-Note: this function logs as pipeFrom.
-
-Not available on Windows. -}
-pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String])
-pipeLinesFrom fp args =
-    do (pid, c) <- pipeFrom fp args
-       return $ (pid, lines c)
-#endif
-#endif
-
-logRunning :: String -> FilePath -> [String] -> IO ()
-logRunning func fp args = return () --debugM (logbase ++ "." ++ func) (showCmd fp args)
-
-warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t
-warnFail funcname fp args msg =
-    let m = showCmd fp args ++ ": " ++ msg
-        in do putStrLn m
-              fail m
-
-ddd s a = do
-	putStrLn $ s ++ " start"
-	r <- a
-	putStrLn $ s ++ " end"
-	return r
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Read data from a pipe.  Returns a Handle and a 'PipeHandle'.
-
-When done, you must hClose the handle, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
-
-This function logs as pipeFrom.
-
-Not available on Windows or with Hugs.
--}
-hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle)
-hPipeFrom fp args =
-    ddd (show ("hPipeFrom", fp, args)) $ do
-       pipepair <- createPipe
-       let childstuff = do dupTo (snd pipepair) stdOutput
-                           closeFd (fst pipepair)
-                           executeFile fp True args Nothing
-       p <- try (forkProcess childstuff)
-       -- parent
-       pid <- case p of
-                  Right x -> return x
-                  Left e -> warnFail "pipeFrom" fp args $
-                            "Error in fork: " ++ show e
-       closeFd (snd pipepair)
-       h <- fdToHandle (fst pipepair)
-       return (PipeHandle pid fp args "pipeFrom", h)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Read data from a pipe.  Returns a lazy string and a 'PipeHandle'.
-
-ONLY AFTER the string has been read completely, You must call either
-'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'.
-Zombies will result otherwise.
-
-Not available on Windows.
--}
-pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String)
-pipeFrom fp args =
-    do (pid, h) <- hPipeFrom fp args
-       c <- hGetContents h
-       return (pid, c)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Write data to a pipe.  Returns a 'PipeHandle' and a new Handle to write
-to.
-
-When done, you must hClose the handle, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
-
-This function logs as pipeTo.
-
-Not available on Windows.
--}
-hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle)
-hPipeTo fp args =
-    ddd "hPipeTo" $ do
-       pipepair <- createPipe
-       let childstuff = do dupTo (fst pipepair) stdInput
-                           closeFd (snd pipepair)
-                           executeFile fp True args Nothing
-       p <- try (forkProcess childstuff)
-       -- parent
-       pid <- case p of
-                   Right x -> return x
-                   Left e -> warnFail "pipeTo" fp args $
-                             "Error in fork: " ++ show e
-       closeFd (fst pipepair)
-       h <- fdToHandle (snd pipepair)
-       return (PipeHandle pid fp args "pipeTo", h)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Write data to a pipe.  Returns a ProcessID.
-
-You must call either
-'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID.
-Zombies will result otherwise.
-
-Not available on Windows.
--}
-pipeTo :: FilePath -> [String] -> String -> IO PipeHandle
-pipeTo fp args message =
-    do (pid, h) <- hPipeTo fp args
-       finally (hPutStr h message)
-               (hClose h)
-       return pid
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns
-a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe).
-
-When done, you must hClose both handles, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
-
-Hint: you will usually need to ForkIO a thread to handle one of the Handles;
-otherwise, deadlock can result.
-
-This function logs as pipeBoth.
-
-Not available on Windows.
--}
-hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle)
-hPipeBoth fp args =
-    ddd (show ("hPipeBoth", fp, args)) $ do
-       frompair <- createPipe
-       topair <- createPipe
-       let childstuff = do dupTo (snd frompair) stdOutput
-                           closeFd (fst frompair)
-                           dupTo (fst topair) stdInput
-                           closeFd (snd topair)
-                           executeFile fp True args Nothing
-       p <- try (forkProcess childstuff)
-       -- parent
-       pid <- case p of
-                   Right x -> return x
-                   Left e -> warnFail "pipeBoth" fp args $
-                             "Error in fork: " ++ show e
-       closeFd (snd frompair)
-       closeFd (fst topair)
-       fromh <- fdToHandle (fst frompair)
-       toh <- fdToHandle (snd topair)
-       return (PipeHandle pid fp args "pipeBoth", fromh, toh)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread
-to send data to the piped program, and simultaneously returns its output
-stream.
-
-The same note about checking the return status applies here as with 'pipeFrom'.
-
-Not available on Windows. -}
-pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String)
-pipeBoth fp args message =
-    do (pid, fromh, toh) <- hPipeBoth fp args
-       forkIO $ finally (hPutStr toh message)
-                        (hClose toh)
-       c <- hGetContents fromh
-       return (pid, c)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-{- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status
-of the given process ID.  If the process terminated normally, does nothing.
-Otherwise, raises an exception with an appropriate error message.
-
-This call will block waiting for the given pid to terminate.
-
-Not available on Windows. -}
-forceSuccess :: PipeHandle -> IO ()
-forceSuccess (PipeHandle pid fp args funcname) =
-    let warnfail = warnFail funcname
-        in do status <- getProcessStatus True False pid
-              case status of
-                Nothing -> warnfail fp args $ "Got no process status"
-                Just (Exited (ExitSuccess)) -> return ()
-                Just (Exited (ExitFailure fc)) ->
-                    cmdfailed funcname fp args fc
-                Just (Terminated sig) ->
-                    warnfail fp args $ "Terminated by signal " ++ show sig
-                Just (Stopped sig) ->
-                    warnfail fp args $ "Stopped by signal " ++ show sig
-#endif
-
-{- | Invokes the specified command in a subprocess, waiting for the result.
-If the command terminated successfully, return normally.  Otherwise,
-raises a userError with the problem.
-
-Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise.
--}
-safeSystem :: FilePath -> [String] -> IO ()
-safeSystem command args =
-    ddd "safeSystem" $ do
-#if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)
-       ec <- rawSystem command args
-       case ec of
-            ExitSuccess -> return ()
-            ExitFailure fc -> cmdfailed "safeSystem" command args fc
-#else
-       ec <- posixRawSystem command args
-       case ec of
-            Exited ExitSuccess -> return ()
-            Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc
-            Terminated s -> cmdsignalled "safeSystem" command args s
-            Stopped s -> cmdsignalled "safeSystem" command args s
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Invokes the specified command in a subprocess, waiting for the result.
-Return the result status.  Never raises an exception.  Only available
-on POSIX platforms.
-
-Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD
-during its execution.
-
-Logs as System.Cmd.Utils.posixRawSystem -}
-posixRawSystem :: FilePath -> [String] -> IO ProcessStatus
-posixRawSystem program args =
-    ddd "posixRawSystem" $ do
-       oldint <- installHandler sigINT Ignore Nothing
-       oldquit <- installHandler sigQUIT Ignore Nothing
-       let sigset = addSignal sigCHLD emptySignalSet
-       oldset <- getSignalMask
-       blockSignals sigset
-       childpid <- forkProcess (childaction oldint oldquit oldset)
-
-       mps <- getProcessStatus True False childpid
-       restoresignals oldint oldquit oldset
-       let retval = case mps of
-                      Just x -> x
-                      Nothing -> error "Nothing returned from getProcessStatus"
-       return retval
-
-    where childaction oldint oldquit oldset =
-              do restoresignals oldint oldquit oldset
-                 executeFile program True args Nothing
-          restoresignals oldint oldquit oldset =
-              do installHandler sigINT oldint Nothing
-                 installHandler sigQUIT oldquit Nothing
-                 setSignalMask oldset
-
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Invokes the specified command in a subprocess, without waiting for
-the result.  Returns the PID of the subprocess -- it is YOUR responsibility
-to use getProcessStatus or getAnyProcessStatus on that at some point.  Failure
-to do so will lead to resource leakage (zombie processes).
-
-This function does nothing with signals.  That too is up to you.
-
-Logs as System.Cmd.Utils.forkRawSystem -}
-forkRawSystem :: FilePath -> [String] -> IO ProcessID
-forkRawSystem program args = ddd "forkRawSystem" $
-    do
-       forkProcess childaction
-    where
-      childaction = executeFile program True args Nothing
-
-#endif
-#endif
-
-cmdfailed :: String -> FilePath -> [String] -> Int -> IO a
-cmdfailed funcname command args failcode = do
-    let errormsg = "Command " ++ command ++ " " ++ (show args) ++
-            " failed; exit code " ++ (show failcode)
-    let e = userError (errormsg)
-    putStrLn errormsg
-    ioError e
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a
-cmdsignalled funcname command args failcode = do
-    let errormsg = "Command " ++ command ++ " " ++ (show args) ++
-            " failed due to signal " ++ (show failcode)
-    let e = userError (errormsg)
-    putStrLn errormsg
-    ioError e
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Open a pipe to the specified command.
-
-Passes the handle on to the specified function.
-
-The 'PipeMode' specifies what you will be doing.  That is, specifing 'ReadFromPipe'
-sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout.
-
-Not available on Windows.
- -}
-pOpen :: PipeMode -> FilePath -> [String] ->
-         (Handle -> IO a) -> IO a
-pOpen pm fp args func = ddd "pOpen" $
-        do
-        pipepair <- createPipe
-        case pm of
-         ReadFromPipe -> do
-                         let callfunc _ = do
-                                        closeFd (snd pipepair)
-                                        h <- fdToHandle (fst pipepair)
-                                        x <- func h
-                                        hClose h
-                                        return $! x
-                         pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
-                                callfunc (closeFd (fst pipepair))
-         WriteToPipe -> do
-                        let callfunc _ = do
-                                       closeFd (fst pipepair)
-                                       h <- fdToHandle (snd pipepair)
-                                       x <- func h
-                                       hClose h
-                                       return $! x
-                        pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
-                               callfunc (closeFd (snd pipepair))
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Runs a command, redirecting things to pipes.
-
-Not available on Windows.
-
-Note that you may not use the same fd on more than one item.  If you
-want to redirect stdout and stderr, dup it first.
--}
-pOpen3 :: Maybe Fd                      -- ^ Send stdin to this fd
-       -> Maybe Fd                      -- ^ Get stdout from this fd
-       -> Maybe Fd                      -- ^ Get stderr from this fd
-       -> FilePath                      -- ^ Command to run
-       -> [String]                      -- ^ Command args
-       -> (ProcessID -> IO a)           -- ^ Action to run in parent
-       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
-       -> IO a
-pOpen3 pin pout perr fp args func childfunc = ddd (show ("pOpen3", fp, args)) $
-    do pid <- pOpen3Raw pin pout perr fp args childfunc
-       putStrLn "got pid"
-       retval <- func $! pid
-       putStrLn "got retval"
-       let rv = seq retval retval
-       forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3")
-       putStrLn "process finished"
-       return rv
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Runs a command, redirecting things to pipes.
-
-Not available on Windows.
-
-Returns immediately with the PID of the child.  Using 'waitProcess' on it
-is YOUR responsibility!
-
-Note that you may not use the same fd on more than one item.  If you
-want to redirect stdout and stderr, dup it first.
--}
-pOpen3Raw :: Maybe Fd                      -- ^ Send stdin to this fd
-       -> Maybe Fd                      -- ^ Get stdout from this fd
-       -> Maybe Fd                      -- ^ Get stderr from this fd
-       -> FilePath                      -- ^ Command to run
-       -> [String]                      -- ^ Command args
-       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
-       -> IO ProcessID
-pOpen3Raw pin pout perr fp args childfunc =
-    let mayberedir Nothing _ = return ()
-        mayberedir (Just fromfd) tofd = do
-                                        dupTo fromfd tofd
-                                        closeFd fromfd
-                                        return ()
-        childstuff = do
-                     mayberedir pin stdInput
-                     mayberedir pout stdOutput
-                     mayberedir perr stdError
-                     childfunc
-                     executeFile fp True args Nothing
-{-
-        realfunc p = do
-                     System.Posix.Signals.installHandler
-                           System.Posix.Signals.sigPIPE
-                           System.Posix.Signals.Ignore
-                           Nothing
-                     func p
--}
-        in
-        ddd "pOpen3Raw" $
-        do
-        p <- try (forkProcess childstuff)
-        pid <- case p of
-                Right x -> return x
-                Left e -> fail ("Error in fork: " ++ (show e))
-        return pid
-
-#endif
-#endif
-
-showCmd :: FilePath -> [String] -> String
-showCmd fp args = fp ++ " " ++ show args

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

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 Control.Exception (bracket)
-import System.Exit
 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'
+	(Just to, Just from, _, pid)
-	_ <- forkIO $ finally (hPutStr toh input) (hClose toh)
+		<- createProcess (proc "gpg" params')
-	output <- hGetContentsStrict fromh
+			{ std_in = CreatePipe
-	forceSuccess pid
+			, std_out = CreatePipe }
-	return output
+	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'
+	(Just toh, Just fromh, _, pid) <- createProcess (proc "gpg" params')
-	pid2 <- forkProcess $ do
+		{ std_in = CreatePipe, std_out = CreatePipe }
-		L.hPut toh =<< a
+	L.hPut toh =<< a
-		hClose toh
-		exitSuccess
 	hClose toh
 	ret <- b fromh
 
 	-- cleanup
-	forceSuccess pid
+	forceSuccessProcess pid "gpg" params'
-	_ <- getProcessStatus True False pid2
 	closeFd frompipe
 	return ret
 

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
+		Just s -> return $ parsesysctl s
-			val <- parsesysctl <$> hGetContentsStrict h
-			void $ getProcessStatus True False $ processID pid
-			return val
 	where
 		parsesysctl s = readish =<< lastMaybe (words s)

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)
+	(_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) []
-	let !r = parse s
+	return $ parse s
-	void $ getProcessStatus True False $ processID pid
-	return r
 
 {- Parsing null-delimited output like:
  -

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

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.Process
-import System.Posix.Process hiding (executeFile)
-import System.Posix.Signals
 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,41 +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
+safeSystemEnv command params environ = do
-	putStrLn "safeSystemEnv start"
+	(_, _, _, pid) <- createProcess (proc command $ toCommand params)
-	-- Going low-level because all the high-level system functions
+		{ env = environ }
-	-- block SIGINT etc. We need to block SIGCHLD, but allow
+	waitForProcess pid
-	-- 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) -> do
-			putStrLn "safeSystemEnv end"
-			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
-	putStrLn "executeFile start"
-	--debugM "Utility.SafeCommand.executeFile" $
-	--	"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
-	System.Posix.Process.executeFile c path p e
-	putStrLn "executeFile end"
 
 {- Escapes a filename or other parameter to be safely able to be exposed to
  - the shell. -}

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

doc/todo/assistant_threaded_runtime.mdwn

@@ -23,6 +23,9 @@ git-annex does not otherwise use threads, so this is surprising. --[[Joey]]
 > I've spent a lot of time debugging this, and trying to fix it, in the
 > "threaded" branch. There are still deadlocks. --[[Joey]]
 
+>> Fixed, by switching from `System.Cmd.Utils` to `System.Process`
+>> --[[Joey]] 
+
 ---
 
 It would be possible to not use the threaded runtime. Instead, we could

git-annex.cabal

@@ -40,11 +40,12 @@ Executable git-annex
    unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
    base == 4.5.*, monad-control, transformers-base, lifted-base,
-   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance
+   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
   -- Need to list this because it's generated from a .hsc file.
   Other-Modules: Utility.Touch
   C-Sources: Utility/libdiskfree.c
   Extensions: CPP
+  GHC-Options: -threaded
 
   if flag(S3)
     Build-Depends: hS3
@@ -65,10 +66,11 @@ Test-Suite test
    unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
    base == 4.5.*, monad-control, transformers-base, lifted-base,
-   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance
+   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
   Other-Modules: Utility.Touch
   C-Sources: Utility/libdiskfree.c
   Extensions: CPP
+  GHC-Options: -threaded
 
 source-repository head
   type: git

test.hs

@@ -14,6 +14,7 @@ import Test.QuickCheck
 import System.Posix.Directory (changeWorkingDirectory)
 import System.Posix.Files
 import System.Posix.Env
+import System.Posix.Process
 import Control.Exception.Extensible
 import qualified Data.Map as M
 import System.IO.HVFS (SystemFS(..))