summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 17:05:25 -0400
committerJoey Hess2014-11-18 17:05:25 -0400
commitefa32839757e7fab14b94a1032741677b076d67e (patch)
tree9553814710f9a9b646f72c6f50cef23d3eb06647 /src
parent09fc55586f0c1a42b0eeedf39f81f7eef00069ca (diff)
reformat
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/CmdLine.hs87
1 files changed, 44 insertions, 43 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 0d7fdd48..707c5956 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -197,54 +197,55 @@ spin hn hst = do
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
- go cacheparams =<< hostprivdata
+ comm cacheparams =<< hostprivdata
unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
error $ "remote propellor failed (running: " ++ runcmd ++")"
where
hostprivdata = show . filterPrivData hst <$> decryptPrivData
- go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
- let loop = do
- status <- getMarked fromh statusMarker
- case readish =<< status of
- Just NeedRepoUrl -> do
- sendMarked toh repoUrlMarker
- =<< (fromMaybe "" <$> getRepoUrl)
- loop
- Just NeedPrivData -> do
- sendprivdata toh privdata
- loop
- Just NeedGitPush -> void $ actionMessage "Git update" $ do
- sendMarked toh gitPushMarker ""
- let p = (proc "git" ["upload-pack", "."])
- { std_in = UseHandle fromh
- , std_out = UseHandle toh
- }
- (Nothing, Nothing, Nothing, h) <- createProcess p
- r <- waitForProcess h
- -- no more protocol possible after
- -- git push
- hClose fromh
- hClose toh
- return (r == ExitSuccess)
- Just NeedGitClone -> do
- hClose toh
- hClose fromh
- sendGitClone hn
- go cacheparams privdata
- -- Ready is only sent by old versions of
- -- propellor. They expect to get privdata,
- -- and then no more protocol communication.
- Just Ready -> do
- sendprivdata toh privdata
- hClose toh
-
- -- Display remaining output.
- void $ tryIO $ forever $
- showremote =<< hGetLine fromh
- hClose fromh
- Nothing -> return ()
- loop
+ comm cacheparams privdata =
+ withBothHandles createProcessSuccess
+ (proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+ (comm' cacheparams privdata)
+ comm' cacheparams privdata (toh, fromh) = loop
+ where
+ loop = dispatch =<< (maybe Nothing readish <$> getMarked fromh statusMarker)
+ dispatch (Just NeedRepoUrl) = do
+ sendMarked toh repoUrlMarker
+ =<< (fromMaybe "" <$> getRepoUrl)
+ loop
+ dispatch (Just NeedPrivData) = do
+ sendprivdata toh privdata
+ loop
+ dispatch (Just NeedGitPush) = do
+ void $ actionMessage ("Sending git update to " ++ hn) $ do
+ sendMarked toh gitPushMarker ""
+ let p = (proc "git" ["upload-pack", "."])
+ { std_in = UseHandle fromh
+ , std_out = UseHandle toh
+ }
+ (Nothing, Nothing, Nothing, h) <- createProcess p
+ r <- waitForProcess h
+ -- no more protocol possible after git push
+ hClose fromh
+ hClose toh
+ return (r == ExitSuccess)
+ dispatch (Just NeedGitClone) = do
+ hClose toh
+ hClose fromh
+ sendGitClone hn
+ comm cacheparams privdata
+ -- Ready is only sent by old versions of
+ -- propellor. They expect to get privdata,
+ -- and then no more protocol communication.
+ dispatch (Just Ready) = do
+ sendprivdata toh privdata
+ hClose toh
+ -- Display remaining output.
+ void $ tryIO $ forever $
+ showremote =<< hGetLine fromh
+ hClose fromh
+ dispatch Nothing = return ()
user = "root@"++hn