summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2016-03-02 14:47:46 -0400
committerJoey Hess2016-03-02 14:58:33 -0400
commit6bb39d0125c8b1cb65eb33cb04fb300601fd4f93 (patch)
tree570237620d5540501b3aa08476c8f3be7f0c62fd /src/Propellor
parent458e74ec9b4fa4e16e3484a972c331d20c29ffa6 (diff)
avoid repeated rebuilds, more type safely
buildFirst re-runs propellor with --continue, which is supposed to make defaultMain bypass subsequent calls to buildFirst. But, use of a Bool to do that caused the code to be unclear, and some of the cases lost track of that. --continue SimpleRun would buildFirst, and if the binary changed, would --continue SimpleRun. This could loop repatedly, on systems such as FreeBSD where building re-links the binary even when there are no changes. As discussed in github pull #11 Fixed by introducing a CanRebuild data type, which buildFirst and updateFirst require in order to do any work makes it more clear what's going on. It's not a type-level proof that propellor won't rebuild repeatedly, but gets closer to one. (Only remaining way such a bug could slip in is if the CanRebuild value was reused in a call to buildFirst and also inside the IO action passed to it.) There were some other weirdnesses around repeated builds. In particular, Run as non-root did an updateFirst, followed by a buildFirst. I think this redundant build was an accident, and have removed it.
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/CmdLine.hs51
1 files changed, 31 insertions, 20 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 6d9db8bf..a5ea1f1c 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -88,6 +88,8 @@ processCmdLine = go =<< getArgs
Just cmdline -> return $ mk cmdline
Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"
+data CanRebuild = CanRebuild | NoRebuild
+
-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = withConcurrentOutput $ do
@@ -95,10 +97,9 @@ defaultMain hostlist = withConcurrentOutput $ do
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
- go True cmdline
+ go CanRebuild cmdline
where
- go _ (Serialized cmdline) = go True cmdline
- go _ (Continue cmdline) = go False cmdline
+ go cr (Serialized cmdline) = go cr cmdline
go _ Check = return ()
go _ (Set field context) = setPrivData field context
go _ (Unset field context) = unsetPrivData field context
@@ -112,22 +113,27 @@ defaultMain hostlist = withConcurrentOutput $ do
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
go _ (GitPush fin fout) = gitPushHelper fin fout
- go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h))
+ go cr (Relay h) = forceConsole >> updateFirst cr (Update (Just h)) (update (Just h))
go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
go _ (Update (Just h)) = update (Just h)
go _ Merge = mergeSpin
- go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
- go True cmdline = updateFirst cmdline $ go False cmdline
- go False (Spin hs mrelay) = do
+ go cr cmdline@(Spin hs mrelay) = buildFirst cr cmdline $ do
unless (isJust mrelay) commitSpin
forM_ hs $ \hn -> withhost hn $ spin mrelay hn
- go False cmdline@(SimpleRun hn) = do
- forceConsole
- buildFirst cmdline $ go False (Run hn)
- go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
- ( onlyprocess $ withhost hn mainProperties
- , go True (Spin [hn] Nothing)
- )
+ go cr (Run hn) = fetchFirst $
+ ifM ((==) 0 <$> getRealUserID)
+ ( onlyprocess $ withhost hn mainProperties
+ , go cr (Spin [hn] Nothing)
+ )
+ go cr (SimpleRun hn) = go cr (Run hn)
+ go cr (Continue cmdline@(SimpleRun _)) =
+ -- --continue SimpleRun is used by --spin,
+ -- and unlike all other uses of --continue, this legacy one
+ -- wants an update first (to get any changes from the
+ -- central git repo)
+ forceConsole >> updateFirst cr cmdline (go NoRebuild cmdline)
+ -- When continuing after a rebuild, don't want to rebuild again.
+ go _ (Continue cmdline) = go NoRebuild cmdline
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
@@ -142,8 +148,8 @@ unknownhost h hosts = errorMessage $ unlines
, "Known hosts: " ++ unwords (map hostName hosts)
]
-buildFirst :: CmdLine -> IO () -> IO ()
-buildFirst cmdline next = do
+buildFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
+buildFirst CanRebuild cmdline next = do
oldtime <- getmtime
buildPropellor
newtime <- getmtime
@@ -155,6 +161,7 @@ buildFirst cmdline next = do
]
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
+buildFirst NoRebuild _ next = next
fetchFirst :: IO () -> IO ()
fetchFirst next = do
@@ -162,11 +169,14 @@ fetchFirst next = do
void fetchOrigin
next
-updateFirst :: CmdLine -> IO () -> IO ()
-updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
+updateFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst canrebuild cmdline next = ifM hasOrigin
+ ( updateFirst' canrebuild cmdline next
+ , next
+ )
-updateFirst' :: CmdLine -> IO () -> IO ()
-updateFirst' cmdline next = ifM fetchOrigin
+updateFirst' :: CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst' CanRebuild cmdline next = ifM fetchOrigin
( do
buildPropellor
void $ boolSystem "./propellor"
@@ -175,6 +185,7 @@ updateFirst' cmdline next = ifM fetchOrigin
]
, next
)
+updateFirst' NoRebuild _ next = next
-- Gets the fully qualified domain name, given a string that might be
-- a short name to look up in the DNS.