summaryrefslogtreecommitdiff
path: root/src/Propellor/CmdLine.hs
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 20:19:10 -0400
committerJoey Hess2014-11-18 20:19:10 -0400
commitd4a4f0193e30aee1ed37ceab7a85760510ac0d1f (patch)
tree8544762105ee684827b21e65733666a74214919f /src/Propellor/CmdLine.hs
parenta0d5f41a6c3bb7ff69c78e014834c8ac92acca22 (diff)
refactor
Diffstat (limited to 'src/Propellor/CmdLine.hs')
-rw-r--r--src/Propellor/CmdLine.hs91
1 files changed, 49 insertions, 42 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 7c7bc65b..91bf2b6f 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -181,46 +181,11 @@ spin hn hst = do
boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
- comm cacheparams =<< hostprivdata
- unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
+ comm hn hst $ withBothHandles createProcessSuccess
+ (proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+ unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
error $ "remote propellor failed (running: " ++ runcmd ++")"
where
- hostprivdata = show . filterPrivData hst <$> decryptPrivData
-
- 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
- dispatch Nothing = return ()
-
user = "root@"++hn
mkcmd = shellWrap . intercalate " ; "
@@ -243,10 +208,52 @@ spin hn hst = do
runcmd = mkcmd
[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
- sendprivdata toh privdata = void $
- actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
- sendMarked toh privDataMarker privdata
- return True
+comm :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
+comm hn hst connect = connect go
+ where
+ go (toh, fromh) = do
+ let loop = go (toh, fromh)
+ v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
+ case v of
+ (Just NeedRepoUrl) -> do
+ sendRepoUrl toh
+ loop
+ (Just NeedPrivData) -> do
+ sendPrivData hn hst toh
+ loop
+ (Just NeedGitPush) -> do
+ sendGitUpdate hn fromh toh
+ -- no more protocol possible after git push
+ hClose fromh
+ hClose toh
+ (Just NeedGitClone) -> do
+ hClose toh
+ hClose fromh
+ sendGitClone hn
+ comm hn hst connect
+ Nothing -> return ()
+
+sendRepoUrl :: Handle -> IO ()
+sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
+
+sendPrivData :: HostName -> Host -> Handle -> IO ()
+sendPrivData hn hst toh = do
+ privdata <- show . filterPrivData hst <$> decryptPrivData
+ void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+ sendMarked toh privDataMarker privdata
+ return True
+
+sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
+sendGitUpdate hn fromh toh =
+ void $ actionMessage ("Sending git update to " ++ hn) $ do
+ sendMarked toh gitPushMarker ""
+ (Nothing, Nothing, Nothing, h) <- createProcess p
+ (==) ExitSuccess <$> waitForProcess h
+ where
+ p = (proc "git" ["upload-pack", "."])
+ { std_in = UseHandle fromh
+ , std_out = UseHandle toh
+ }
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()