propellor spin

This commit is contained in:
Joey Hess 2014-11-18 13:59:50 -04:00
parent 9463963d85
commit 45f8ebf0ef
Failed to extract signature
2 changed files with 49 additions and 27 deletions

View File

@ -196,8 +196,13 @@ spin hn hst = do
hostprivdata = show . filterPrivData hst <$> decryptPrivData hostprivdata = show . filterPrivData hst <$> decryptPrivData
go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
let comm = do
status <- getMarked fromh statusMarker status <- getMarked fromh statusMarker
case readish =<< status of case readish =<< status of
Just RepoUrl -> do
sendMarked toh repoUrlMarker
=<< (fromMaybe "" <$> getRepoUrl)
comm
Just Ready -> do Just Ready -> do
sendprivdata toh "privdata" privDataMarker privdata sendprivdata toh "privdata" privDataMarker privdata
hClose toh hClose toh
@ -209,9 +214,10 @@ spin hn hst = do
Just NeedGitClone -> do Just NeedGitClone -> do
hClose toh hClose toh
hClose fromh hClose fromh
sendGitClone hn =<< getUrl sendGitClone hn
go cacheparams privdata go cacheparams privdata
Nothing -> error $ "protocol error; received: " ++ show status Nothing -> error $ "protocol error; received: " ++ show status
comm
user = "root@"++hn user = "root@"++hn
@ -243,8 +249,8 @@ spin hn hst = do
return True return True
-- Initial git clone, used for bootstrapping. -- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> String -> IO () sendGitClone :: HostName -> IO ()
sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch branch <- getCurrentBranch
cacheparams <- sshCachingParams hn cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id 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 checkout -b " ++ branch
, "git remote rm origin" , "git remote rm origin"
, "rm -f " ++ remotebundle , "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 :: IO ()
boot = do boot = do
sendMarked stdout statusMarker (show RepoUrl)
maybe noop setRepoUrl
=<< getMarked stdin repoUrlMarker
sendMarked stdout statusMarker (show Ready) sendMarked stdout statusMarker (show Ready)
makePrivDataDir makePrivDataDir
maybe noop (writeFileProtected privDataLocal) maybe noop (writeFileProtected privDataLocal)
=<< getMarked stdin privDataMarker =<< getMarked stdin privDataMarker
getUrl :: IO String setRepoUrl :: String -> IO ()
getUrl = maybe nourl return =<< getM get urls 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 where
urls = ["remote.deploy.url", "remote.origin.url"] urls = ["remote.deploy.url", "remote.origin.url"]
nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
get u = do get u = do
v <- catchMaybeIO $ v <- catchMaybeIO $
takeWhile (/= '\n') takeWhile (/= '\n')

View File

@ -9,7 +9,7 @@ import Data.List
import Propellor import Propellor
data BootStrapStatus = Ready | NeedGitClone data BootStrapStatus = Ready | NeedGitClone | RepoUrl
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
type Marker = String type Marker = String
@ -21,6 +21,9 @@ statusMarker = "STATUS"
privDataMarker :: String privDataMarker :: String
privDataMarker = "PRIVDATA " privDataMarker = "PRIVDATA "
repoUrlMarker :: String
repoUrlMarker = "REPOURL "
toMarked :: Marker -> String -> String toMarked :: Marker -> String -> String
toMarked marker = intercalate "\n" . map (marker ++) . lines toMarked marker = intercalate "\n" . map (marker ++) . lines