diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +propellor (2.10.0) unstable; urgency=medium + + * The Propellor.Property.Spin added in the last release is replaced + with a very different Propellor.Property.ControlHeir. + + -- Joey Hess Tue, 20 Oct 2015 21:29:12 -0400 + propellor (2.9.0) unstable; urgency=medium * Added basic Uwsgi module, maintained by Félix Sipma. diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (2.10.0) unstable; urgency=medium + + * The Propellor.Property.Spin added in the last release is replaced + with a very different Propellor.Property.ControlHeir. + + -- Joey Hess Tue, 20 Oct 2015 21:29:12 -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 --- 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 @@ -76,6 +76,7 @@ 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 @@ 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 --- /dev/null +++ b/src/Propellor/Property/ControlHeir.hs @@ -0,0 +1,209 @@ +{-# 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 + +-- | 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) + + 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 --- 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