avoid double-build in --spin
It was fetching from the central repo, then building that, and then running the client-to-client git update, and the building after that. Remove the first build, as all that linking does take time.
This commit is contained in:
parent
2ceace6bd5
commit
025c7c4b8e
|
@ -87,6 +87,7 @@ defaultMain hostlist = do
|
||||||
go _ (DockerChain hn s) = withhost hn $ Docker.chain s
|
go _ (DockerChain hn s) = withhost hn $ Docker.chain s
|
||||||
go _ (DockerInit hn) = Docker.init hn
|
go _ (DockerInit hn) = Docker.init hn
|
||||||
go _ (GitPush fin fout) = gitPushHelper fin fout
|
go _ (GitPush fin fout) = gitPushHelper fin fout
|
||||||
|
go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
|
||||||
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
|
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
|
||||||
go True cmdline = updateFirst cmdline $ go False cmdline
|
go True cmdline = updateFirst cmdline $ go False cmdline
|
||||||
go False (Spin hn) = withhost hn $ spin hn
|
go False (Spin hn) = withhost hn $ spin hn
|
||||||
|
@ -96,9 +97,6 @@ defaultMain hostlist = do
|
||||||
( onlyprocess $ withhost hn mainProperties
|
( onlyprocess $ withhost hn mainProperties
|
||||||
, go True (Spin hn)
|
, go True (Spin hn)
|
||||||
)
|
)
|
||||||
go False (Update _) = do
|
|
||||||
forceConsole
|
|
||||||
onlyprocess update
|
|
||||||
|
|
||||||
withhost :: HostName -> (Host -> IO ()) -> IO ()
|
withhost :: HostName -> (Host -> IO ()) -> IO ()
|
||||||
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
|
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
|
||||||
|
@ -127,35 +125,23 @@ buildFirst cmdline next = do
|
||||||
where
|
where
|
||||||
getmtime = catchMaybeIO $ getModificationTime "propellor"
|
getmtime = catchMaybeIO $ getModificationTime "propellor"
|
||||||
|
|
||||||
|
fetchFirst :: IO () -> IO ()
|
||||||
|
fetchFirst next = do
|
||||||
|
whenM hasOrigin $
|
||||||
|
void fetchOrigin
|
||||||
|
next
|
||||||
|
|
||||||
updateFirst :: CmdLine -> IO () -> IO ()
|
updateFirst :: CmdLine -> IO () -> IO ()
|
||||||
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
|
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
|
||||||
|
|
||||||
updateFirst' :: CmdLine -> IO () -> IO ()
|
updateFirst' :: CmdLine -> IO () -> IO ()
|
||||||
updateFirst' cmdline next = do
|
updateFirst' cmdline next = ifM fetchOrigin
|
||||||
branchref <- getCurrentBranch
|
( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
|
||||||
let originbranch = "origin" </> branchref
|
|
||||||
|
|
||||||
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
|
|
||||||
|
|
||||||
oldsha <- getCurrentGitSha1 branchref
|
|
||||||
|
|
||||||
whenM (doesFileExist keyring) $
|
|
||||||
ifM (verifyOriginBranch originbranch)
|
|
||||||
( do
|
|
||||||
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
|
|
||||||
hFlush stdout
|
|
||||||
void $ boolSystem "git" [Param "merge", Param originbranch]
|
|
||||||
, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
|
|
||||||
)
|
|
||||||
|
|
||||||
newsha <- getCurrentGitSha1 branchref
|
|
||||||
|
|
||||||
if oldsha == newsha
|
|
||||||
then next
|
|
||||||
else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
|
|
||||||
( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
|
( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
|
||||||
, errorMessage "Propellor build failed!"
|
, errorMessage "Propellor build failed!"
|
||||||
)
|
)
|
||||||
|
, next
|
||||||
|
)
|
||||||
|
|
||||||
spin :: HostName -> Host -> IO ()
|
spin :: HostName -> Host -> IO ()
|
||||||
spin hn hst = do
|
spin hn hst = do
|
||||||
|
|
|
@ -62,3 +62,25 @@ verifyOriginBranch originbranch = do
|
||||||
nukeFile $ privDataDir </> "pubring.gpg"
|
nukeFile $ privDataDir </> "pubring.gpg"
|
||||||
nukeFile $ privDataDir </> "gpg.conf"
|
nukeFile $ privDataDir </> "gpg.conf"
|
||||||
return (s == "U\n" || s == "G\n")
|
return (s == "U\n" || s == "G\n")
|
||||||
|
|
||||||
|
-- Returns True if HEAD is changed by fetching and merging from origin.
|
||||||
|
fetchOrigin :: IO Bool
|
||||||
|
fetchOrigin = do
|
||||||
|
branchref <- getCurrentBranch
|
||||||
|
let originbranch = "origin" </> branchref
|
||||||
|
|
||||||
|
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
|
||||||
|
|
||||||
|
oldsha <- getCurrentGitSha1 branchref
|
||||||
|
|
||||||
|
whenM (doesFileExist keyring) $
|
||||||
|
ifM (verifyOriginBranch originbranch)
|
||||||
|
( do
|
||||||
|
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
|
||||||
|
hFlush stdout
|
||||||
|
void $ boolSystem "git" [Param "merge", Param originbranch]
|
||||||
|
, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
|
||||||
|
)
|
||||||
|
|
||||||
|
newsha <- getCurrentGitSha1 branchref
|
||||||
|
return $ oldsha /= newsha
|
||||||
|
|
Loading…
Reference in New Issue