From 84413dd508f20e4f62293b4c925962b8dfe2987e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 21 Oct 2015 15:08:41 -0400 Subject: 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. --- src/Propellor/Property/Conductor.hs | 307 ++++++++++++++++++++++++++++++++++ src/Propellor/Property/ControlHeir.hs | 212 ----------------------- 2 files changed, 307 insertions(+), 212 deletions(-) create mode 100644 src/Propellor/Property/Conductor.hs delete mode 100644 src/Propellor/Property/ControlHeir.hs (limited to 'src') 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 -- cgit v1.2.3