{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-} -- | 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.Container 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. -- -- There are instances for single hosts, and for lists of hosts. -- With a list, each listed host 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. class Conductable c where conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where conducts h = conductorFor h notConductorFor h instance Conductable [Host] where conducts hs = propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) propertyList desc (toProps $ map (undoRevertableProperty . 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 fromInfo (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') where combineos o = case mapMaybe (`combineOrchestras` o) os of [] -> [o] os'' -> os'' combineOrchestras' a@(Conductor h _) (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 (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 go h | isOrchestrated (fromInfo (hostInfo h)) = h | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) removeold' h oldconductor = setContainerProps h $ containerProps h ! conductedBy oldconductor oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ \(oldconductor, NotConductorFor l) -> if any (sameHost h) l then Just oldconductor else Nothing 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 $ setContainerProps h $ containerProps 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 + UnixLike) conductorFor h = go `setInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where desc = cdesc (hostName h) go :: Property UnixLike go = property desc $ 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 ) -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) notConductorFor h = (doNothing :: Property UnixLike) `setInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) where desc = "not " ++ cdesc (hostName h) conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike conductorKnownHost h = mk Ssh.knownHost mk Ssh.unknownHost where mk p = p [h] (hostName h) (User "root") -- 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') $ fromInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. conductedBy :: Host -> RevertableProperty UnixLike UnixLike conductedBy h = (setup teardown) `describe` ("conducted by " ++ hostName h) where setup = User "root" `Ssh.authorizedKeysFrom` (User "root", h) `requires` Ssh.installed teardown = User "root" `Ssh.unauthorizedKeysFrom` (User "root", h) 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