From 979fc0e4c03bf6ccd88873f561040bfa1133111d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 20:39:44 -0400 Subject: 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. --- src/Propellor/Spin.hs | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) (limited to 'src/Propellor/Spin.hs') 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" -- cgit v1.2.3