Merge branch 'joeyconfig'

5 files changed, 62 insertions, 28 deletions

diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index d3550e88..a13734b4 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -6,8 +6,6 @@ import System.Directory
 import Data.Maybe
 import Data.List.Utils
 import Control.Monad
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
 import Control.Applicative
 import Prelude
 
@@ -16,6 +14,7 @@ import Propellor.Message
 import Propellor.Git.Config
 import Utility.SafeCommand
 import Utility.Process
+import Utility.Process.NonConcurrent
 import Utility.Monad
 import Utility.Misc
 import Utility.Tmp
@@ -144,12 +143,7 @@ gitCommit msg ps = do
 	let ps' = Param "commit" : ps ++
 		maybe [] (\m -> [Param "-m", Param m]) msg
 	ps'' <- gpgSignParams ps'
-	if isNothing msg
-		then do
-			(_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $
-				proc "git" (toCommand ps'')
-			checkSuccessProcess p
-		else boolSystem "git" ps''
+	boolSystemNonConcurrent "git" ps''
 
 gpgDecrypt :: FilePath -> IO String
 gpgDecrypt f = do
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 2ed75e33..ac7b00d3 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -34,8 +34,6 @@ import "mtl" Control.Monad.Reader
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as L
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
 import Control.Applicative
 import Data.Monoid
 import Prelude
@@ -52,12 +50,12 @@ import Utility.PartialPrelude
 import Utility.Exception
 import Utility.Tmp
 import Utility.SafeCommand
+import Utility.Process.NonConcurrent
 import Utility.Misc
 import Utility.FileMode
 import Utility.Env
 import Utility.Table
 import Utility.FileSystemEncoding
-import Utility.Process
 
 -- | Allows a Property to access the value of a specific PrivDataField,
 -- for use in a specific Context or HostContext.
@@ -196,8 +194,7 @@ editPrivData field context = do
 		hClose th
 		maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v
 		editor <- getEnvDefault "EDITOR" "vi"
-		(_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f]
-		unlessM (checkSuccessProcess p) $
+		unlessM (boolSystemNonConcurrent editor [File f]) $
 			error "Editor failed; aborting."
 		PrivData <$> readFile f
 	setPrivDataTo field context v'
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 495ebaf4..83654105 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -30,6 +30,7 @@ import Propellor.Types.Info
 import qualified Propellor.Shim as Shim
 import Utility.FileMode
 import Utility.SafeCommand
+import Utility.Process.NonConcurrent
 
 commitSpin :: IO ()
 commitSpin = do
@@ -59,7 +60,7 @@ commitSpin = do
 	-- us needing to send stuff directly to the remote host.
 	whenM hasOrigin $
 		void $ actionMessage "Push to central git repository" $
-			boolSystem "git" [Param "push"]
+			boolSystemNonConcurrent "git" [Param "push"]
 
 spin :: Maybe HostName -> HostName -> Host -> IO ()
 spin = spin' Nothing
@@ -83,7 +84,7 @@ spin' mprivdata relay target hst = do
 		=<< getprivdata
 
 	-- And now we can run it.
-	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
+	unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
 		error "remote propellor failed"
   where
 	hn = fromMaybe target relay
@@ -187,9 +188,9 @@ update forhost = do
 			hClose stdout
 			-- Not using git pull because git 2.5.0 badly
 			-- broke its option parser.
-			unlessM (boolSystem "git" (pullparams hin hout)) $
+			unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
 				errorMessage "git fetch from client failed"
-			unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $
+			unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
 				errorMessage "git merge from client failed"
   where
 	pullparams hin hout =
@@ -212,8 +213,13 @@ updateServer
 	-> CreateProcess
 	-> PrivMap
 	-> IO ()
-updateServer target relay hst connect haveprecompiled privdata =
-	withIOHandles createProcessSuccess connect go
+updateServer target relay hst connect haveprecompiled privdata = do
+	(Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect
+		{ std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	go (toh, fromh)
+	forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid
   where
 	hn = fromMaybe target relay
 
@@ -276,8 +282,8 @@ sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
 	cacheparams <- sshCachingParams hn
 	withTmpFile "propellor.git" $ \tmp _ -> allM id
 		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
+		, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+		, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
 		]
   where
 	remotebundle = "/usr/local/propellor.git"
@@ -313,8 +319,8 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
 		withTmpFile "propellor.tar." $ \tarball _ -> allM id
 			[ boolSystem "strip" [File me]
 			, boolSystem "tar" [Param "czf", File tarball, File shimdir]
-			, boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
-			, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
+			, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
+			, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
 			]
 
 	remotetarball = "/usr/local/propellor.tar"
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index c6699961e..ed02f49e 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -18,6 +18,7 @@ module Utility.Process (
 	readProcessEnv,
 	writeReadProcessEnv,
 	forceSuccessProcess,
+	forceSuccessProcess',
 	checkSuccessProcess,
 	ignoreFailureProcess,
 	createProcessSuccess,
@@ -129,11 +130,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
 -- | Waits for a ProcessHandle, and throws an IOError 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 -> fail $ showCmd p ++ " exited " ++ show n
+forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p
+
+forceSuccessProcess' :: CreateProcess -> ExitCode -> IO ()
+forceSuccessProcess' _ ExitSuccess = return ()
+forceSuccessProcess' p (ExitFailure n) = fail $
+	showCmd p ++ " exited " ++ show n
 
 -- | Waits for a ProcessHandle and returns True if it exited successfully.
 -- Note that using this with createProcessChecked will throw away
diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs
new file mode 100644
index 00000000..d25d2a24
--- /dev/null
+++ b/src/Utility/Process/NonConcurrent.hs
@@ -0,0 +1,35 @@
+{- Running processes in the foreground, not via the concurrent-output
+ - layer.
+ -
+ - Avoid using this in propellor properties!
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.NonConcurrent where
+
+import System.Process
+import System.Exit
+import System.IO
+import Utility.SafeCommand
+import Control.Applicative
+import Prelude
+
+boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool
+boolSystemNonConcurrent cmd params = do
+	(Nothing, Nothing, Nothing, p) <- createProcessNonConcurrent $
+		proc cmd (toCommand params)
+	dispatch <$> waitForProcessNonConcurrent p
+  where
+	dispatch ExitSuccess = True
+	dispatch _ = False
+
+createProcessNonConcurrent :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcessNonConcurrent = createProcess
+
+waitForProcessNonConcurrent  :: ProcessHandle -> IO ExitCode
+waitForProcessNonConcurrent  = waitForProcess