From 4e038a43cc9978af1015c53ab7cf27355d989069 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 17 Oct 2015 13:57:51 -0400 Subject: use Info to detect controller loops Much less invasive than the other implementation. --- src/Propellor/CmdLine.hs | 7 ++--- src/Propellor/Engine.hs | 11 +++----- src/Propellor/Property/Spin.hs | 62 ++++++++++++++++++++++++++++++------------ src/Propellor/Spin.hs | 8 ++---- src/Propellor/Types/CmdLine.hs | 9 ------ 5 files changed, 54 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 1225f411..e0830693 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -119,14 +119,11 @@ defaultMain hostlist = do go True cmdline = updateFirst cmdline $ go False cmdline go False (Spin hs r) = do commitSpin - forM_ hs $ \hn -> withhost hn $ - spin hn r mempty + forM_ hs $ \hn -> withhost hn $ spin hn r go False cmdline@(SimpleRun hn) = buildFirst cmdline $ go False (Run hn) - go False cmdline@(ControlledRun hn cc) = buildFirst cmdline $ - onlyprocess $ withhost hn $ mainProperties cc go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyprocess $ withhost hn $ mainProperties mempty + ( onlyprocess $ withhost hn mainProperties , go True (Spin [hn] Nothing) ) diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 021ddd2c..8c1d09c6 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -27,8 +27,6 @@ import Propellor.Types import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Types.Info -import Propellor.Types.CmdLine import Propellor.Property import Utility.Exception import Utility.PartialPrelude @@ -36,9 +34,9 @@ import Utility.Monad -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. -mainProperties :: ControllerChain -> Host -> IO () -mainProperties cc host = do - ret <- runPropellor host' $ +mainProperties :: Host -> IO () +mainProperties host = do + ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] h <- mkMessageHandle whenConsole h $ @@ -48,8 +46,7 @@ mainProperties cc host = do FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess where - ps = map ignoreInfo $ hostProperties host' - host' = addHostInfo host (InfoVal cc) + ps = map ignoreInfo $ hostProperties host -- | Runs a Propellor action with the specified host. -- diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs index 79485569..81ff24f6 100644 --- a/src/Propellor/Property/Spin.hs +++ b/src/Propellor/Property/Spin.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Propellor.Property.Spin ( Spinnable(..), @@ -9,23 +9,31 @@ module Propellor.Property.Spin ( import Propellor.Base import Propellor.Spin (spin) -import Propellor.Types.CmdLine (ControllerChain(..)) import Propellor.Types.Info import qualified Propellor.Property.Ssh as Ssh +import qualified Data.Set as S + -- | A class of things that can be spinned. class Spinnable t where - toSpin :: t -> Property NoInfo + toSpin :: t -> Property HasInfo instance Spinnable Host where - toSpin h = go `requires` Ssh.knownHost [h] (hostName h) (User "root") + toSpin h = infoProperty desc go (mkControllingInfo h) [] + `requires` Ssh.knownHost [h] (hostName h) (User "root") where - go = property (cdesc (hostName h)) $ do - ControllerChain cc <- getControllerChain - if hostName h `elem` cc - then noChange -- avoid loop + desc = cdesc (hostName h) + go = do + thishost <- ask + if isControllerLoop thishost h + then errorMessage $ unwords + [ "controller loop detected involving" + , hostName thishost + , "and" + , hostName h + ] else do - liftIO $ spin (hostName h) Nothing (ControllerChain cc) h + liftIO $ spin (hostName h) Nothing h -- Don't know if the spin made a change to the -- remote host or not, but in any case, the -- local host was not changed. @@ -93,7 +101,7 @@ instance Spinnable [Host] where -- -- Chains of controllers are supported; host A can control host B which -- controls host C. Loops of controllers are automatically prevented. -controllerFor :: Spinnable h => h -> Property NoInfo +controllerFor :: Spinnable h => h -> Property HasInfo controllerFor h = toSpin h `requires` Ssh.installed @@ -112,10 +120,30 @@ controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h) cdesc :: String -> Desc cdesc n = "controller for " ++ n --- | The current host is included on the chain, as well as any hosts that --- acted as controllers to get the current propellor process to run. -getControllerChain :: Propellor ControllerChain -getControllerChain = do - hn <- hostName <$> ask - ControllerChain cc <- fromMaybe (ControllerChain []) . fromInfoVal <$> askInfo - return (ControllerChain (hn:cc)) +-- To detect loops of controlled hosts, each Host's info contains a list +-- of the hosts it's controlling. +newtype Controlling = Controlled [Host] + deriving (Typeable, Monoid) + +isControlledBy :: Host -> Controlling -> Bool +h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs) + +instance IsInfo Controlling where + propigateInfo _ = False + +mkControllingInfo :: Host -> Info +mkControllingInfo controlled = addInfo mempty (Controlled [controlled]) + +getControlledBy :: Host -> Controlling +getControlledBy = getInfo . hostInfo + +isControllerLoop :: Host -> Host -> Bool +isControllerLoop controller controlled = go S.empty controlled + where + go checked h + | controller `isControlledBy` c = True + -- avoid checking loops that have been checked before + | hostName h `S.member` checked = False + | otherwise = any (go (S.insert (hostName h) checked)) l + where + c@(Controlled l) = getControlledBy h diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 401c9375..ecefbf6e 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -40,8 +40,8 @@ commitSpin = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] -spin :: HostName -> Maybe HostName -> ControllerChain -> Host -> IO () -spin target relay cc hst = do +spin :: HostName -> Maybe HostName -> Host -> IO () +spin target relay hst = do cacheparams <- if viarelay then pure ["-A"] else toCommand <$> sshCachingParams hn @@ -89,9 +89,7 @@ spin target relay cc hst = do runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd cmd = if viarelay then "--serialized " ++ shellEscape (show (Spin [target] (Just target))) - else if cc == mempty - then "--continue " ++ shellEscape (show (SimpleRun target)) - else "--continue " ++ shellEscape (show (ControlledRun target cc)) + else "--continue " ++ shellEscape (show (SimpleRun target)) -- Check if the Host contains an IP address that matches one of the IPs -- in the DNS for the HostName. If so, the HostName is used as-is, diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs index ca73c902..558c6e8b 100644 --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -1,20 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} - module Propellor.Types.CmdLine where import Propellor.Types.OS import Propellor.Types.PrivData import System.Posix.Types -import Data.Typeable -import Data.Monoid -- | All the command line actions that propellor can perform. data CmdLine = Run HostName | Spin [HostName] (Maybe HostName) | SimpleRun HostName - | ControlledRun HostName ControllerChain | Set PrivDataField Context | Unset PrivDataField Context | UnsetUnused @@ -34,7 +29,3 @@ data CmdLine | GitPush Fd Fd | Check deriving (Read, Show, Eq) - --- | List of hosts that acted as controllers to cause a host to be spinned. -newtype ControllerChain = ControllerChain [HostName] - deriving (Read, Show, Eq, Typeable, Monoid) -- cgit v1.2.3