summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Spin.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Spin.hs')
-rw-r--r--src/Propellor/Property/Spin.hs62
1 files changed, 45 insertions, 17 deletions
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