From 6bb39d0125c8b1cb65eb33cb04fb300601fd4f93 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Mar 2016 14:47:46 -0400 Subject: 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. --- src/Propellor/CmdLine.hs | 51 +++++++++++++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 20 deletions(-) (limited to 'src/Propellor/CmdLine.hs') 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. -- cgit v1.2.3