summaryrefslogtreecommitdiff
path: root/src/Propellor/Spin.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Spin.hs')
-rw-r--r--src/Propellor/Spin.hs26
1 files changed, 16 insertions, 10 deletions
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"