summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-21 15:08:41 -0400
committerJoey Hess2015-10-21 15:35:52 -0400
commit84413dd508f20e4f62293b4c925962b8dfe2987e (patch)
tree92afed2955a09da155f29ac7d504f062b4946b6c
parent0e39d53352b982022747e451676bc6a66e3d9acc (diff)
Rewrote Propellor.Property.ControlHeir one more time, renaming it to Propellor.Property.Conductor.
Wow, really.. So, this gets back to having properties that are added to hosts to say what they conduct. I think that conducts webservers `before` conducts dnsserver is an important thing to be able to express. Untested except for eyeballing the resulting Host data.
-rw-r--r--debian/changelog7
-rw-r--r--propellor.cabal4
-rw-r--r--src/Propellor/Property/Conductor.hs307
-rw-r--r--src/Propellor/Property/ControlHeir.hs212
4 files changed, 316 insertions, 214 deletions
diff --git a/debian/changelog b/debian/changelog
index f8bd5ad5..32f6e310 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+propellor (2.11.0) UNRELEASED; urgency=medium
+
+ * Rewrote Propellor.Property.ControlHeir one more time, renaming it to
+ Propellor.Property.Conductor.
+
+ -- Joey Hess <id@joeyh.name> Wed, 21 Oct 2015 15:06:26 -0400
+
propellor (2.10.0) unstable; urgency=medium
* The Propellor.Property.Spin added in the last release is replaced
diff --git a/propellor.cabal b/propellor.cabal
index 516bdde2..7471fb52 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.10.0
+Version: 2.11.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -76,7 +76,7 @@ Library
Propellor.Property.Apache
Propellor.Property.Apt
Propellor.Property.Cmd
- Propellor.Property.ControlHeir
+ Propellor.Property.Conductor
Propellor.Property.Hostname
Propellor.Property.Chroot
Propellor.Property.ConfFile
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
new file mode 100644
index 00000000..7c85858b
--- /dev/null
+++ b/src/Propellor/Property/Conductor.hs
@@ -0,0 +1,307 @@
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+-- | This module adds conductors to propellor. A conductor is a Host that
+-- is responsible for running propellor on other hosts
+--
+-- This eliminates the need to manually run propellor --spin to
+-- update the conducted hosts, and can be used to orchestrate updates
+-- to hosts.
+--
+-- The conductor needs to be able to ssh to the hosts it conducts,
+-- and run propellor, as root. To this end,
+-- the `Propellor.Property.Ssh.knownHost` property is automatically
+-- added to the conductor, so it knows the host keys of the relevant hosts.
+-- Also, each conducted host is configured to let its conductor
+-- ssh in as root, by automatically adding the
+-- `Propellor.Property.Ssh.authorizedKeysFrom` property.
+--
+-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to
+-- configure the ssh keys for the root user on conductor hosts,
+-- and to use `Ssh.hostKeys` to configure the host keys for the
+-- conducted hosts.
+--
+-- For example, if you have some webservers and a dnsserver,
+-- and want the master host to conduct all of them:
+--
+-- > import Propellor
+-- > import Propellor.Property.Conductor
+-- > import qualified Propellor.Property.Ssh as Ssh
+-- > import qualified Propellor.Property.Cron as Cron
+-- >
+-- > main = defaultMain (orchestrate hosts)
+-- >
+-- > hosts =
+-- > [ master
+-- > , 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")]
+-- > & conducts webservers
+-- > `before` conducts dnsserver
+-- > & Cron.runPropellor
+--
+-- Notice that, in the above example, the the webservers are conducted
+-- first. Only once the webservers have successfully been set up is the
+-- dnsserver updated. This way, when adding a new web server, the dns
+-- won't list it until it's ready.
+--
+-- There can be multiple conductors, and conductors can conduct other
+-- conductors if you need such a hierarchy. (Loops in the hierarchy, such
+-- as a host conducting itself, are detected and automatically broken.)
+--
+-- While it's allowed for a single host to be conducted by
+-- multiple conductors, the results can be discordent.
+-- Since only one propellor process can be run on a host at a time,
+-- one of the conductors will fail to communicate with it.
+--
+-- Note that a conductor can see all PrivData of the hosts it conducts.
+
+module Propellor.Property.Conductor (
+ orchestrate,
+ Conductable(..),
+) where
+
+import Propellor.Base
+import Propellor.Spin (spin')
+import Propellor.PrivData.Paths
+import Propellor.Types.Info
+import qualified Propellor.Property.Ssh as Ssh
+
+import qualified Data.Set as S
+
+-- | Class of things that can be conducted.
+class Conductable c where
+ conducts :: c -> RevertableProperty
+
+instance Conductable Host where
+ -- | Conduct the specified host.
+ conducts h = conductorFor h <!> notConductorFor h
+
+-- | Each host in the list will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
+instance Conductable [Host] where
+ conducts hs =
+ propertyList desc (map (toProp . conducts) hs)
+ <!>
+ propertyList desc (map (toProp . revert . conducts) hs)
+ where
+ desc = cdesc $ unwords $ map hostName hs
+
+data Orchestra
+ = Conductor Host [Orchestra]
+ | Conducted Host
+
+instance Show Orchestra where
+ show (Conductor h l) = "Conductor " ++ hostName h ++ " (" ++ show l ++ ")"
+ show (Conducted h) = "Conducted " ++ hostName h
+
+fullOrchestra :: Orchestra -> Bool
+fullOrchestra (Conductor _ _) = True
+fullOrchestra (Conducted _) = False
+
+topHost :: Orchestra -> Host
+topHost (Conducted h) = h
+topHost (Conductor h _) = h
+
+allHosts :: Orchestra -> [Host]
+allHosts (Conducted h) = [h]
+allHosts (Conductor h l) = h : concatMap allHosts l
+
+-- Makes an Orchestra for the host, and any hosts it's conducting.
+mkOrchestra :: Host -> Orchestra
+mkOrchestra = fromJust . go S.empty
+ where
+ go seen h
+ | S.member (hostName h) seen = Nothing -- break loop
+ | otherwise = Just $ case getInfo (hostInfo h) of
+ ConductorFor [] -> Conducted h
+ ConductorFor l ->
+ let seen' = S.insert (hostName h) seen
+ in Conductor h (mapMaybe (go seen') l)
+
+-- Combines the two orchestras, if there's a place, or places where they
+-- can be grafted together.
+combineOrchestras :: Orchestra -> Orchestra -> Maybe Orchestra
+combineOrchestras a b = combineOrchestras' a b <|> combineOrchestras' b a
+
+combineOrchestras' :: Orchestra -> Orchestra -> Maybe Orchestra
+combineOrchestras' (Conducted h) b
+ | sameHost h (topHost b) = Just b
+ | otherwise = Nothing
+combineOrchestras' (Conductor h os) (Conductor h' os')
+ | sameHost h h' = Just $ Conductor h (concatMap (combineos os) os')
+ where
+ combineos os o = case mapMaybe (`combineOrchestras` o) os of
+ [] -> [o]
+ os' -> os'
+combineOrchestras' a@(Conductor h os) (Conducted h')
+ | sameHost h h' = Just a
+combineOrchestras' (Conductor h os) b
+ | null (catMaybes (map snd osgrafts)) = Nothing
+ | otherwise = Just $ Conductor h (map (uncurry fromMaybe) osgrafts)
+ where
+ osgrafts = zip os (map (`combineOrchestras` b) os)
+
+sameHost :: Host -> Host -> Bool
+sameHost a b = hostName a == hostName b
+
+-- Removes any loops that may be present in the Orchestra involving
+-- the passed Host. This is a matter of traversing the Orchestra
+-- top-down, and removing all occurrances of the host after the first
+-- one seen.
+deloop :: Host -> Orchestra -> Orchestra
+deloop _ (Conducted h) = Conducted h
+deloop thehost c@(Conductor htop ostop) = Conductor htop $
+ fst $ seekh [] ostop (sameHost htop thehost)
+ where
+ seekh l [] seen = (l, seen)
+ seekh l ((Conducted h) : rest) seen
+ | sameHost h thehost =
+ if seen
+ then seekh l rest seen
+ else seekh (Conducted h : l) rest True
+ | otherwise = seekh (Conducted h:l) rest seen
+ seekh l ((Conductor h os) : rest) seen
+ | sameHost h thehost =
+ if seen
+ then seekh l rest seen
+ else
+ let (os', _seen') = seekh [] os True
+ in seekh (Conductor h os' : l) rest True
+ | otherwise =
+ let (os', seen') = seekh [] os seen
+ in seekh (Conductor h os' : l) rest seen'
+
+-- Extracts the Orchestras from a list of hosts.
+--
+-- Method: For each host that is a conductor, check the
+-- list of orchesteras to see if any already contain that host, or
+-- any of the hosts it conducts. If so, add the host to that
+-- orchestra. If not, start a new orchestra.
+--
+-- The result is a set of orchestras, which are each fully disconnected
+-- from the other. Some may contain loops.
+extractOrchestras :: [Host] -> [Orchestra]
+extractOrchestras = filter fullOrchestra . go [] . map mkOrchestra
+ where
+ go os [] = os
+ go os (o:rest) =
+ let os' = zip os (map (combineOrchestras o) os)
+ in case catMaybes (map snd os') of
+ [] -> go (o:os) rest
+ [_] -> go (map (uncurry fromMaybe) os') rest
+ _ -> error "Bug: Host somehow ended up in multiple Orchestras!"
+
+-- | Pass this a list of all your hosts; it will finish setting up
+-- orchestration as configured by the `conducts` properties you add to
+-- hosts.
+--
+-- > main = defaultMain $ orchestrate hosts
+orchestrate :: [Host] -> [Host]
+orchestrate hs = map go hs
+ where
+ os = extractOrchestras hs
+ go h
+ | isOrchestrated (getInfo (hostInfo h)) = h
+ | otherwise = foldl orchestrate' h (map (deloop h) os)
+
+orchestrate' :: Host -> Orchestra -> Host
+orchestrate' h (Conducted _) = h
+orchestrate' h (Conductor c l)
+ | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
+ | any (sameHost h) (map topHost l) = cont $ h
+ & conductedBy c
+ | otherwise = cont h
+ where
+ cont h' = foldl orchestrate' h' l
+
+-- The host this property is added to becomes the conductor for the
+-- specified Host. Note that `orchestrate` must be used for this property
+-- to have any effect.
+conductorFor :: Host -> Property HasInfo
+conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
+ `requires` Ssh.knownHost [h] (hostName h) (User "root")
+ `requires` Ssh.installed
+ where
+ desc = cdesc (hostName h)
+
+ go = ifM (isOrchestrated <$> askInfo)
+ ( do
+ pm <- liftIO $ filterPrivData h
+ <$> readPrivDataFile privDataLocal
+ liftIO $ spin' (Just pm) Nothing (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
+ , do
+ warningMessage "Can't conduct; either orchestrate has not been used, or there is a conductor loop."
+ return FailedChange
+ )
+
+-- Gives a conductor access to all the PrivData of the specified hosts.
+-- This allows it to send it on the the hosts when conducting it.
+--
+-- This is not done in conductorFor, so that it can be added
+-- at the orchestration stage, and so is not added when there's a loop.
+addConductorPrivData :: Host -> [Host] -> Host
+addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
+ where
+ i = mempty
+ `addInfo` mconcat (map privinfo hs)
+ `addInfo` Orchestrated (Any True)
+ privinfo h = forceHostContext (hostName h) $ getInfo (hostInfo h)
+
+-- Reverts conductorFor.
+notConductorFor :: Host -> Property HasInfo
+notConductorFor h = pureInfoProperty desc (NotConductorFor [h])
+ where
+ desc = "not " ++ cdesc (hostName h)
+
+-- Use this property to let the specified conductor ssh in and run propellor.
+conductedBy :: Host -> Property NoInfo
+conductedBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
+ `describe` ("conducted by " ++ hostName h)
+ `requires` Ssh.installed
+
+cdesc :: String -> Desc
+cdesc n = "conducting " ++ n
+
+-- A Host's Info indicates when it's a conductor for hosts, and when it's
+-- stopped being a conductor.
+newtype ConductorFor = ConductorFor [Host]
+ deriving (Typeable, Monoid)
+newtype NotConductorFor = NotConductorFor [Host]
+ deriving (Typeable, Monoid)
+
+instance Show ConductorFor where
+ show (ConductorFor l) = "ConductorFor " ++ show (map hostName l)
+instance Show NotConductorFor where
+ show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l)
+
+instance IsInfo ConductorFor where
+ propagateInfo _ = False
+instance IsInfo NotConductorFor where
+ propagateInfo _ = False
+
+-- Added to Info when a host has been orchestrated.
+newtype Orchestrated = Orchestrated Any
+ deriving (Typeable, Monoid, Show)
+instance IsInfo Orchestrated where
+ propagateInfo _ = False
+
+isOrchestrated :: Orchestrated -> Bool
+isOrchestrated (Orchestrated v) = getAny v
diff --git a/src/Propellor/Property/ControlHeir.hs b/src/Propellor/Property/ControlHeir.hs
deleted file mode 100644
index ce993a02..00000000
--- a/src/Propellor/Property/ControlHeir.hs
+++ /dev/null
@@ -1,212 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-
-module Propellor.Property.ControlHeir (
- ControlHeir(..),
- ControlList(..),
- addControlHeir,
- ControllerOf(..),
-) where
-
-import Propellor.Base
-import Propellor.Spin (spin')
-import Propellor.PrivData.Paths
-import Propellor.Types.Info
-import qualified Propellor.Property.Ssh as Ssh
-
--- | 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 thehost (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 thehost = Nothing
- | otherwise = Just (Controlled h')
- removeh' (Controller h' cl')
- | hostName h' == hostName thehost = 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)
-
- -- 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)
-
- go = do
- pm <- liftIO $ filterPrivData h
- <$> readPrivDataFile privDataLocal
- liftIO $ spin' (Just pm) Nothing (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
-
--- | 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
-
--- | A 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