Force ssh, scp, and git commands to be run in the foreground.

Before, they could run in the background if another process was running,
and so their output wouldn't immediately be visible.

With this change, the concurrent-output layer is not used for these
interactive commands.

4 files changed, 53 insertions, 26 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 7f8c87a2..83654105 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -30,8 +30,7 @@ import Propellor.Types.Info
 import qualified Propellor.Shim as Shim
 import Utility.FileMode
 import Utility.SafeCommand
-
-import System.Console.Concurrent
+import Utility.Process.NonConcurrent
 
 commitSpin :: IO ()
 commitSpin = do
@@ -61,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,10 +82,9 @@ spin' mprivdata relay target hst = do
 		(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
 		(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
 		=<< getprivdata
-	async $ createProcessForeground $ proc "sleep" ["500"]
 
 	-- 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
@@ -190,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 =
@@ -215,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
 
@@ -279,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"
@@ -316,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/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs
new file mode 100644
index 00000000..27eb5e92
--- /dev/null
+++ b/src/Utility/Process/NonConcurrent.hs
@@ -0,0 +1,33 @@
+{- 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
+
+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