Merge branch 'threaded' into assistant

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 =
-			pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do
-				sha <- fst . separate (== ' ') <$> hGetLine h
-				if null sha
-					then error $ command ++ " parse error"
-					else return sha
+		parse command [] = bad command
+		parse command (l:_)
+			| null sha = bad command
+			| otherwise = sha
+			where
+				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 $
-			pOpen ReadFromPipe cmd (toCommand params) $
-				Git.Config.hRead r
+		pipedconfig cmd params = safely $ do
+			(_, Just h, _, pid) <-
+				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

@@ -73,12 +73,10 @@ commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
 commit message branch parentrefs repo = do
 	tree <- getSha "write-tree" $
 		pipeRead [Param "write-tree"] repo
-	sha <- getSha "commit-tree" $
-		ignorehandle $ pipeWriteRead
-			(map Param $ ["commit-tree", show tree] ++ ps)
-			message repo
+	sha <- getSha "commit-tree" $ pipeWriteRead
+		(map Param $ ["commit-tree", show tree] ++ ps)
+		message repo
 	run "update-ref" [Param $ show branch, Param $ show sha] repo
 	return sha
 	where
-		ignorehandle a = snd <$> a
 		ps = concatMap (\r -> ["-p", show r]) parentrefs

Git/Command.hs

@@ -7,10 +7,8 @@
 
 module Git.Command where
 
-import qualified Data.Text.Lazy as L
-import qualified Data.Text.Lazy.IO as L
-import Control.Concurrent
-import Control.Exception (finally)
+import System.Process
+import System.Posix.Process (getAnyProcessStatus)
 
 import Common
 import Git
@@ -44,29 +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.
- - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
-pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String)
-pipeWriteRead params s repo = assertLocal repo $ do
-	(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
-	fileEncoding to
-	fileEncoding from
-	_ <- forkIO $ finally (hPutStr to s) (hClose to)
-	c <- hGetContents from
-	return (p, c)
+{- 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 $
+	readProcess "git" (toCommand $ gitCommandLine params repo) s
 
 {- 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 $
-			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
-				hRead repo
+		git_config d = do
+			(_, Just h, _, pid)
+				<- 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/HashObject.hs

@@ -38,11 +38,9 @@ hashFile h file = CoProcess.query h send receive
 {- Injects some content into git, returning its Sha. -}
 hashObject :: ObjectType -> String -> Repo -> IO Sha
 hashObject objtype content repo = getSha subcmd $ do
-	(h, s) <- pipeWriteRead (map Param params) content repo
-	length s `seq` do
-		forceSuccess h
-		reap -- XXX unsure why this is needed
-		return s
+	s <- pipeWriteRead (map Param params) content repo
+	reap -- XXX unsure why this is needed, of if it is anymore
+	return s
 	where
 		subcmd = "hash-object"
 		params = [subcmd, "-t", show objtype, "-w", "--stdin"]

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 {}) =
-	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
+runAction repo action@(CommandAction {}) = do
+	(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/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

Makefile

@@ -14,7 +14,7 @@ endif
 
 PREFIX=/usr
 IGNORE=-ignore-package monads-fd -ignore-package monads-tf
-BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
+BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
 GHCFLAGS=-O2 $(BASEFLAGS)
 CFLAGS=-Wall
 

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 $
-			pOpen ReadFromPipe cmd (toCommand params) $
-				Git.Config.hRead r
+		pipedconfig cmd params = safely $ do
+			(_, Just h, _, pid) <-
+				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] $
-					Git.Config.hRead r
+				pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
 
 		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
-			pid <- forkProcess $ do
-				_ <- 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"
+			env <- hookEnv k Nothing
+			findkey <$> readProcessEnv "sh" ["-c", hook] env

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

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

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)

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

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

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

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/design/assistant/blog/day_37__back.mdwn

@@ -0,0 +1,64 @@
+Back home and laptop is fixed.. back to work.
+
+Warmup exercises:
+
+* Went in to make it queue transfers when a broken symlink is received,
+  only to find I'd already written code to do that, and forgotten about it.
+  Heh. Did check that the git-annex branch is always sent first,
+  which will ensure that code always knows where to transfer a key from.
+  I had probably not considered this wrinkle when first writing the code;
+  it worked by accident.
+
+* Made the assistant check that a remote is known to have a key before
+  queueing a download from it.
+
+* Fixed a bad interaction between the `git annex map` command and the
+  assistant.
+
+----
+
+Tried using a modified version of `MissingH` that doesn't use `HSLogger`
+to make git-annex work with the threaded GHC runtime. Unfortunatly,
+I am still seeing hangs in at least 3 separate code paths when
+running the test suite. I may have managed to fix one of the hangs,
+but have not grokked what's causing the others.
+
+----
+
+I now have access to a Mac OSX system, thanks to Kevin M. I've fixed
+some portability problems in git-annex with it before, but today I tested
+the assistant on it:
+
+* Found a problem with the kqueue code that prevents incoming pushes from
+  being noticed.
+
+  The problem was that the newly added git ref file does not trigger an add
+  event. The kqueue code saw a generic change event for the refs directory,
+  but since the old file was being deleted and replaced by the new file,
+  the kqueue code, which already had the old file in its cache, did not notice
+  the file had been replaced.
+
+  I fixed that by making the kqueue code also track the inode of each file.
+  Currently that adds the overhead of a stat of each file, which could be
+  avoided if haskell exposed the inode returned by `readdir`. Room to
+  optimise this later...
+
+* Also noticed that the kqueue code was not separating out file deletions
+  from directory deletions. IIRC Jimmy had once mentioned a problem with file
+  deletions not being noticed by the assistant, and this could be responsible
+  for that, although the directory deletion code seems to handle them ok
+  normally. It was making the transfer watching thread not notice when
+  any transfers finished, for sure. I fixed this oversight, looking in the
+  cache to see if there used to be a file or a directory, and running the
+  appropriate hook.
+
+Even with these fixes, the assistant does not yet reliably transfer file
+contents on OSX. I think the problem is that with kqueue we're not
+guaranteed to get an add event, and a deletion event for a transfer
+info file -- if it's created and quickly deleted, the code that
+synthensizes those events doesn't run in time to know it existed.
+Since the transfer code relies on deletion events to tell when transfers
+are complete, it stops sending files after the first transfer, if the
+transfer ran so quickly it doesn't get the expected events. 
+
+So, will need to work on OSX support some more...

doc/design/assistant/syncing.mdwn

@@ -10,6 +10,13 @@ all the other git clones, at both the git level and the key/value level.
   on remotes, and transfer. But first, need to ensure that when a remote
   receives content, and updates its location log, it syncs that update
   out.
+* Transfer watching has a race on kqueue systems, which makes finished
+  fast transfers not be noticed by the TransferWatcher. Which in turn
+  prevents the transfer slot being freed and any further transfers
+  from happening. So, this approach is too fragile to rely on for
+  maintaining the TransferSlots. Instead, need [[todo/assistant_threaded_runtime]],
+  which would allow running something for sure when a transfer thread
+  finishes.
 
 ## longer-term TODO
 

doc/todo/assistant_threaded_runtime.mdwn

@@ -20,6 +20,12 @@ The test suite tends to hang when testing add. `git-annex` occasionally
 hangs, apparently in a futex lock. This is not the assistant hanging, and
 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

@@ -1,5 +1,5 @@
 Name: git-annex
-Version: 3.20120629
+Version: 3.20120630
 Cabal-Version: >= 1.8
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>
@@ -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(..))