summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 13:59:50 -0400
committerJoey Hess2014-11-18 13:59:50 -0400
commit45f8ebf0ef0d152af3b3c77492e4a5e442e304b6 (patch)
tree646965dd40d62319fb1fbe5fbabd4bb3025964da /src
parent9463963d855d6a19d423598f668b8627dd669a30 (diff)
propellor spin
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/CmdLine.hs71
-rw-r--r--src/Propellor/Protocol.hs5
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