summaryrefslogtreecommitdiff
path: root/src/Propellor/Spin.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-06 20:39:44 -0400
committerJoey Hess2016-03-06 20:50:52 -0400
commit979fc0e4c03bf6ccd88873f561040bfa1133111d (patch)
tree2fd505aef8cf863af079f8a31830a6cc721b304b /src/Propellor/Spin.hs
parentd09a67ea25be77300a4eeb06b7c922b0c28c5d25 (diff)
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.
Diffstat (limited to 'src/Propellor/Spin.hs')
-rw-r--r--src/Propellor/Spin.hs29
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"