summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-17 13:57:51 -0400
committerJoey Hess2015-10-17 13:58:31 -0400
commit4e038a43cc9978af1015c53ab7cf27355d989069 (patch)
tree36621411192ca62bbb552de5277e1ca3c4c35670
parenta487fd07dc72ba506b3d185c4d9317e5a443faa3 (diff)
use Info to detect controller loops
Much less invasive than the other implementation.
-rw-r--r--config-joey.hs2
-rw-r--r--src/Propellor/CmdLine.hs7
-rw-r--r--src/Propellor/Engine.hs11
-rw-r--r--src/Propellor/Property/Spin.hs62
-rw-r--r--src/Propellor/Spin.hs8
-rw-r--r--src/Propellor/Types/CmdLine.hs9
6 files changed, 56 insertions, 43 deletions
diff --git a/config-joey.hs b/config-joey.hs
index b5982161..f862a2fb 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -27,6 +27,7 @@ import qualified Propellor.Property.Journald as Journald
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Aiccu as Aiccu
import qualified Propellor.Property.OS as OS
+import qualified Propellor.Property.Spin as Spin
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
import qualified Propellor.Property.HostingProvider.Linode as Linode
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
@@ -189,6 +190,7 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
kite :: Host
kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
[ "Welcome to kite!" ]
+ & Spin.controllerFor clam
& ipv4 "66.228.36.95"
& ipv6 "2600:3c03::f03c:91ff:fe73:b0d2"
& alias "kitenet.net"
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)