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.hs52
1 files changed, 52 insertions, 0 deletions
diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs
new file mode 100644
index 00000000..24b8a3b6
--- /dev/null
+++ b/src/Propellor/Property/Spin.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Property.Spin (Controlled(..), controller) where
+
+import Propellor.Base
+import Propellor.Spin (spin)
+import Propellor.Types.CmdLine (ControllerChain(..))
+import Propellor.Types.Info
+
+class Controlled t where
+ toHosts :: t -> [Host]
+
+instance Controlled Host where
+ toHosts h = [h]
+
+instance Controlled [Host] where
+ toHosts = id
+
+-- | The Host that has this Property is in control of some other Hosts.
+--
+-- Making a host a controller eliminates the need to manually run
+-- propellor --spin to update the controlled hosts. Each time
+-- propellor is run on the controller host, it will in turn run
+-- propellor on the controlled Hosts.
+--
+-- Multiple controllers can control the same hosts. However, if
+-- propellor is already running on a host, its controller will fail
+-- to run it a second time. So, if two controllers both try to
+-- control the same host at the same time, one will fail.
+--
+-- Chains of controllers are supported; host A can control host B which
+-- controls host C. Loops of controllers are automatically prevented.
+controller :: Controlled h => h -> Property NoInfo
+controller h = propertyList "controller" (map controller' (toHosts h))
+
+controller' :: Host -> Property NoInfo
+controller' h = property ("controller for " ++ hostName h) $ do
+ ControllerChain cc <- getControllerChain
+ if hostName h `elem` cc
+ then noChange -- avoid loop
+ else do
+ liftIO $ spin (hostName h) Nothing (ControllerChain cc) 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.
+ noChange
+
+getControllerChain :: Propellor ControllerChain
+getControllerChain = do
+ hn <- hostName <$> ask
+ ControllerChain cc <- fromMaybe (ControllerChain []) . fromInfoVal <$> askInfo
+ return (ControllerChain (hn:cc))