diff options
Diffstat (limited to 'src/Propellor/Spin.hs')
| -rw-r--r-- | src/Propellor/Spin.hs | 29 |
1 files changed, 16 insertions, 13 deletions
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" |