summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-20 21:28:49 -0400
committerJoey Hess2015-10-20 21:28:49 -0400
commit51a831c56ec42a9702ac8eb6980d9b9947a5ad30 (patch)
tree7438bfc4f1fde8348d1f026dbd903c302970a117
parenteeabdf5e30d5b5f88788151e1f0231d8ea562562 (diff)
The Propellor.Property.Spin added in the last release is replaced with a very different Propellor.Property.ControlHeir.
Rethought it because it turned out that propigating the PrivData rendered the loop detection pointless, because when there was a loop, each host included the other's PrivData, which in turn lead to a loop. And, it was not possible to break that loop. So, changed from adding properties to hosts to a top-down hierarchy that makes changes as needed when applied to the hosts. Which makes it easy to detect and break loops. Aka: The Ur Quan know what they're up to.
-rw-r--r--debian/changelog7
-rw-r--r--propellor.cabal4
-rw-r--r--src/Propellor/Property/ControlHeir.hs211
-rw-r--r--src/Propellor/Property/Spin.hs160
4 files changed, 220 insertions, 162 deletions
diff --git a/debian/changelog b/debian/changelog
index b11fccc1..3aedf66f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+propellor (2.10.0) UNRELEASED; urgency=medium
+
+ * The Propellor.Property.Spin added in the last release is replaced
+ with a very different Propellor.Property.ControlHeir.
+
+ -- Joey Hess <id@joeyh.name> Tue, 20 Oct 2015 21:24:10 -0400
+
propellor (2.9.0) unstable; urgency=medium
* Added basic Uwsgi module, maintained by FĂ©lix Sipma.
diff --git a/propellor.cabal b/propellor.cabal
index b61d2a2f..516bdde2 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.9.0
+Version: 2.10.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -76,6 +76,7 @@ Library
Propellor.Property.Apache
Propellor.Property.Apt
Propellor.Property.Cmd
+ Propellor.Property.ControlHeir
Propellor.Property.Hostname
Propellor.Property.Chroot
Propellor.Property.ConfFile
@@ -109,7 +110,6 @@ Library
Propellor.Property.Prosody
Propellor.Property.Reboot
Propellor.Property.Rsync
- Propellor.Property.Spin
Propellor.Property.Scheduled
Propellor.Property.Service
Propellor.Property.Ssh
diff --git a/src/Propellor/Property/ControlHeir.hs b/src/Propellor/Property/ControlHeir.hs
new file mode 100644
index 00000000..6cf376be
--- /dev/null
+++ b/src/Propellor/Property/ControlHeir.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+module Propellor.Property.ControlHeir (
+ ControlHeir(..),
+ ControlList(..),
+ addControlHeir,
+ ControllerOf(..),
+) where
+
+import Propellor.Base
+import Propellor.Spin (spin, SpinMode(..))
+import Propellor.Types.Info
+import qualified Propellor.Property.Ssh as Ssh
+
+import qualified Data.Set as S
+
+-- | A hierarchy of control. When propellor is run on a host that
+-- is a Controller, it in turn spins each of the hosts in its control
+-- list.
+--
+-- There can be multiple levels of controllers in the hierarchy.
+--
+-- Multiple controllers can control the same hosts. However, when
+-- propellor is already running on a host, a controller will fail
+-- to spin it. So, if two controllers both try to control the same
+-- host at the same time, one will fail.
+--
+-- (Loops in the hierarchy, such as a host controlling itself,
+-- are detected and automatically broken.)
+data ControlHeir
+ = Controller Host ControlList
+ | Controlled Host
+
+instance Show ControlHeir where
+ show (Controller h l) = "Controller " ++ hostName h ++ " (" ++ show l ++ ")"
+ show (Controlled h) = "Controlled " ++ hostName h
+
+data ControlList
+ -- | A list of hosts to control. Failure to spin one host does not
+ -- prevent spinning later hosts in the list.
+ = ControlList [ControlHeir]
+ -- | Requires the first host to be successfully spinned before
+ -- proceeding to spin the hosts in the ControlList.
+ | ControlReq ControlHeir ControlList
+ deriving (Show)
+
+listHeir :: ControlList -> [ControlHeir]
+listHeir (ControlList l) = l
+listHeir (ControlReq h l) = h : listHeir l
+
+class DirectlyControlled a where
+ directlyControlled :: a -> [Host]
+
+instance DirectlyControlled ControlHeir where
+ directlyControlled (Controlled h) = [h]
+ directlyControlled (Controller h _) = [h]
+
+instance DirectlyControlled ControlList where
+ directlyControlled = concatMap directlyControlled . listHeir
+
+-- Removes any loops that may be present in the ControlHeir involving
+-- the passed Host. This is a simple matter of removing the Host from any
+-- sub-hierarchies.
+deloop :: Host -> ControlHeir -> ControlHeir
+deloop _ (Controlled h) = Controlled h
+deloop host (Controller h cl) = Controller h (removeh cl)
+ where
+ removeh (ControlList l) = ControlList (mapMaybe removeh' l)
+ removeh (ControlReq ch cl) = case removeh' ch of
+ Just ch' -> ControlReq ch' (removeh cl)
+ Nothing -> removeh cl
+ removeh' (Controlled h')
+ | hostName h' == hostName host = Nothing
+ | otherwise = Just (Controlled h')
+ removeh' (Controller h' cl)
+ | hostName h' == hostName host = Nothing
+ | otherwise = Just (Controller h' (removeh cl))
+
+-- | Applies a ControlHeir to a list of hosts.
+--
+-- This 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 each of the controlled Hosts.
+--
+-- The controller needs to be able to ssh to the hosts it controls,
+-- and run propellor, as root. To this end,
+-- the `Propellor.Property.Ssh.knownHost` property is added to the
+-- controller, so it knows the host keys of the hosts it controlls.
+--
+-- Each controlled host is configured to let its controller
+-- ssh in as root. This is done by adding the
+-- `Propellor.Property.Ssh.authorizedKeysFrom` property, with
+-- `User "root"`.
+--
+-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to
+-- configure the ssh keys for the root user on controller hosts,
+-- and to use `Ssh.hostKeys` to configure the host keys for the controlled
+-- hosts.
+--
+-- For example, if you have some webservers and a dnsserver,
+-- and want a master that runs propellor on all of them:
+--
+-- > import Propellor
+-- > import Propellor.Property.ControlHeir
+-- > import qualified Propellor.Property.Ssh as Ssh
+-- > import qualified Propellor.Property.Cron as Cron
+-- >
+-- > main = defaultMain (hosts `addControlHeir` control)
+-- >
+-- > hosts =
+-- > [ master
+-- > , dnsserver
+-- > ] ++ webservers
+-- >
+-- > control = Controller master (ControlList (map Controlled (dnsserver:webservers)))
+-- >
+-- > dnsserver = host "dns.example.com"
+-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
+-- > & ...
+-- >
+-- > webservers =
+-- > [ host "www1.example.com"
+-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
+-- > & ...
+-- > , ...
+-- > ]
+-- >
+-- > master = host "master.example.com"
+-- > & Ssh.userKeys (User "root") [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
+-- > & Cron.runPropellor
+--
+-- Note that a controller can see all PrivData of the hosts below it in
+-- the ControlHeir.
+addControlHeir :: [Host] -> ControlHeir -> [Host]
+addControlHeir hs (Controlled _) = hs
+addControlHeir hs c@(Controller _ _)
+ | any isController hs = error "Detected repeated applications of addControlHeir. Since loop prevention only works within a single application, repeated application is unsafe and not allowed."
+ | otherwise = map (\h -> addControlHeir' h (deloop h c)) hs
+
+-- Walk through the ControlHeir, and add properties to the Host
+-- depending on where it appears in the ControlHeir.
+-- (Loops are already removed before this point.)
+addControlHeir' :: Host -> ControlHeir -> Host
+addControlHeir' h (Controlled _) = h
+addControlHeir' h (Controller controller l)
+ | hn == hostName controller = cont $
+ h & mkcontroller l
+ | hn `elem` map hostName (directlyControlled l) = cont $
+ h & controlledBy controller
+ | otherwise = cont h
+ where
+ hn = hostName h
+
+ cont h' = foldl addControlHeir' h' (listHeir l)
+
+ mkcontroller (ControlList l') =
+ mkcontroller' (concatMap directlyControlled l')
+ mkcontroller (ControlReq h' l') =
+ mkcontroller' (directlyControlled h')
+ `before` mkcontroller l'
+ mkcontroller' l' = propertyList
+ (cdesc $ unwords $ map hostName l')
+ (map controllerFor l')
+
+-- | The host this property is added to becomes the controller for the
+-- specified Host.
+controllerFor :: Host -> Property HasInfo
+controllerFor h = infoProperty desc go (mkControllingInfo h <> privinfo) []
+ `requires` Ssh.knownHost [h] (hostName h) (User "root")
+ `requires` Ssh.installed
+ where
+ desc = cdesc (hostName h)
+
+ go = do
+ liftIO $ spin ControllingSpin (hostName h) 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
+
+ -- Make the controlling host have all the remote host's
+ -- PrivData, so it can send it on to the remote host
+ -- when spinning it.
+ privinfo = addInfo mempty $
+ forceHostContext (hostName h) $
+ getInfo (hostInfo h)
+
+-- | Use this property to let the specified controller Host ssh in
+-- and run propellor.
+controlledBy :: Host -> Property NoInfo
+controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
+ `requires` Ssh.installed
+
+cdesc :: String -> Desc
+cdesc n = "controller for " ++ n
+
+-- | Each Host's info contains a list of the names of hosts it's controlling.
+newtype ControllerOf = ControllerOf [HostName]
+ deriving (Typeable, Monoid, Show)
+
+instance IsInfo ControllerOf where
+ propagateInfo _ = True
+
+mkControllingInfo :: Host -> Info
+mkControllingInfo controlled = addInfo mempty (ControllerOf [hostName controlled])
+
+isController :: Host -> Bool
+isController h = case getInfo (hostInfo h) of
+ ControllerOf [] -> False
+ _ -> True
diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs
deleted file mode 100644
index 144f8197..00000000
--- a/src/Propellor/Property/Spin.hs
+++ /dev/null
@@ -1,160 +0,0 @@
-{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-
-module Propellor.Property.Spin (
- Spinnable(..),
- controllerFor,
- controllerKeys,
- controlledBy,
-) where
-
-import Propellor.Base
-import Propellor.Spin (spin, SpinMode(..))
-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 HasInfo
-
-instance Spinnable Host where
- toSpin h = infoProperty desc go (mkControllingInfo h <> privinfo) []
- `requires` Ssh.knownHost [h] (hostName h) (User "root")
- where
- 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 ControllingSpin (hostName h) 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
- -- Make the controlling host have all the remote host's
- -- PrivData, so it can send it on to the remote host
- -- when spinning it.
- privinfo = addInfo mempty $
- forceHostContext (hostName h) $
- getInfo (hostInfo h)
-
--- | Each Host in the list is spinned in turn. Does not stop on spin
--- failure; does propagate overall success/failure.
-instance Spinnable [Host] where
- toSpin l = propertyList (cdesc $ unwords $ map hostName l) (map toSpin l)
-
--- | The Host that has this Property is in control of running propellor on
--- 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.
---
--- The controller needs to be able to ssh to the hosts it controls,
--- and run propellor, as root. The controller is automatically configured
--- with `Propellor.Property.Ssh.knownHost` to know the host keys of the
--- hosts that it will ssh to. It's up to you to use `controllerKeys`
--- and `controlledBy` to set up the ssh keys that will let the controller
--- log into the hosts it controls.
---
--- For example, if you have some webservers and a dnsserver,
--- and want a master that runs propellor on all of them:
---
--- > import Propellor
--- > import qualified Propellor.Property.Spin as Spin
--- > import qualified Propellor.Property.Ssh as Ssh
--- > import qualified Propellor.Property.Cron as Cron
--- >
--- > main = defaultMain hosts
--- >
--- > hosts =
--- > [ master
--- > , dnsserver
--- > ] ++ webservers
--- >
--- > dnsserver = host "dns.example.com"
--- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
--- > & Spin.controlledBy master
--- > & ...
--- >
--- > webservers =
--- > [ host "www1.example.com"
--- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
--- > & Spin.controlledBy master
--- > & ...
--- > , ...
--- > ]
--- >
--- > master = host "master.example.com"
--- > & Spin.controllerKeys [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
--- > -- Only update dnsserver once all webservers are successfully updated.
--- > & Spin.controllerFor dnsserver
--- > `requires` Spin.controllerFor webservers
--- > & Cron.runPropellor
---
--- Multiple controllers can control the same hosts. However, when
--- propellor is already running on a host, a controller will fail
--- to run it. 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.
---
--- Note that a controller can see all PrivInfo of the hosts it controls.
-controllerFor :: Spinnable h => h -> Property HasInfo
-controllerFor h = toSpin h
- `requires` Ssh.installed
-
--- | Uses `Propellor.Property.Ssh.keysImported` to set up the ssh keys
--- for the root user on a controller.
---
--- (The corresponding private keys come from the privdata.)
-controllerKeys :: [(SshKeyType, Ssh.PubKeyText)] -> Property HasInfo
-controllerKeys ks = Ssh.userKeys (User "root") hostContext ks
- `requires` Ssh.installed
-
--- | Use this property to let the specified controller Host ssh in
--- and run propellor.
-controlledBy :: Host -> Property NoInfo
-controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
- `requires` Ssh.installed
-
-cdesc :: String -> Desc
-cdesc n = "controller for " ++ n
-
--- 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, Show)
-
-isControlledBy :: Host -> Controlling -> Bool
-h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs)
-
-instance IsInfo Controlling where
- propagateInfo _ = True
-
-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