From 45f8ebf0ef0d152af3b3c77492e4a5e442e304b6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Nov 2014 13:59:50 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 71 ++++++++++++++++++++++++++++++----------------- src/Propellor/Protocol.hs | 5 +++- 2 files changed, 49 insertions(+), 27 deletions(-) diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index c133b7d8..bc420dd9 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -196,22 +196,28 @@ spin hn hst = do hostprivdata = show . filterPrivData hst <$> decryptPrivData go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do - status <- getMarked fromh statusMarker - case readish =<< status of - Just Ready -> do - sendprivdata toh "privdata" privDataMarker privdata - hClose toh - - -- Display remaining output. - void $ tryIO $ forever $ - showremote =<< hGetLine fromh - hClose fromh - Just NeedGitClone -> do - hClose toh - hClose fromh - sendGitClone hn =<< getUrl - go cacheparams privdata - Nothing -> error $ "protocol error; received: " ++ show status + let comm = do + status <- getMarked fromh statusMarker + case readish =<< status of + Just RepoUrl -> do + sendMarked toh repoUrlMarker + =<< (fromMaybe "" <$> getRepoUrl) + comm + Just Ready -> do + sendprivdata toh "privdata" privDataMarker privdata + hClose toh + + -- Display remaining output. + void $ tryIO $ forever $ + showremote =<< hGetLine fromh + hClose fromh + Just NeedGitClone -> do + hClose toh + hClose fromh + sendGitClone hn + go cacheparams privdata + Nothing -> error $ "protocol error; received: " ++ show status + comm user = "root@"++hn @@ -243,8 +249,8 @@ spin hn hst = do return True -- Initial git clone, used for bootstrapping. -sendGitClone :: HostName -> String -> IO () -sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do +sendGitClone :: HostName -> IO () +sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do branch <- getCurrentBranch cacheparams <- sshCachingParams hn withTmpFile "propellor.git" $ \tmp _ -> allM id @@ -260,25 +266,38 @@ sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) , "git checkout -b " ++ branch , "git remote rm origin" , "rm -f " ++ remotebundle - , "git remote add origin " ++ url - -- same as --set-upstream-to, except origin branch - -- may not have been pulled yet - , "git config branch."++branch++".remote origin" - , "git config branch."++branch++".merge refs/heads/"++branch ] +-- Called "boot" for historical reasons, but what this really does is +-- update the privdata, repo url, and git repo over the ssh connection from the +-- client that ran propellor --spin. boot :: IO () boot = do + sendMarked stdout statusMarker (show RepoUrl) + maybe noop setRepoUrl + =<< getMarked stdin repoUrlMarker sendMarked stdout statusMarker (show Ready) makePrivDataDir maybe noop (writeFileProtected privDataLocal) =<< getMarked stdin privDataMarker -getUrl :: IO String -getUrl = maybe nourl return =<< getM get urls +setRepoUrl :: String -> IO () +setRepoUrl "" = return () +setRepoUrl url = do + rs <- lines <$> readProcess "git" ["remote"] + let subcmd = if "origin" `elem` rs then "set-url" else "add" + void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url] + -- same as --set-upstream-to, except origin branch + -- may not have been pulled yet + branch <- getCurrentBranch + let branchval s = "branch." ++ branch ++ "." ++ s + void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"] + void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch] + +getRepoUrl :: IO (Maybe String) +getRepoUrl = getM get urls where urls = ["remote.deploy.url", "remote.origin.url"] - nourl = errorMessage $ "Cannot find deploy url in " ++ show urls get u = do v <- catchMaybeIO $ takeWhile (/= '\n') diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs index 669f41b6..4dc7e6bb 100644 --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -9,7 +9,7 @@ import Data.List import Propellor -data BootStrapStatus = Ready | NeedGitClone +data BootStrapStatus = Ready | NeedGitClone | RepoUrl deriving (Read, Show, Eq) type Marker = String @@ -21,6 +21,9 @@ statusMarker = "STATUS" privDataMarker :: String privDataMarker = "PRIVDATA " +repoUrlMarker :: String +repoUrlMarker = "REPOURL " + toMarked :: Marker -> String -> String toMarked marker = intercalate "\n" . map (marker ++) . lines -- cgit v1.2.3