path: root/src/Propellor/Property/Conductor.hs

{-# 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.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 (HasInfo + UnixLike) (HasInfo + UnixLike)

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 (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 = modifyHostProps h $ hostProps 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 $
		modifyHostProps h $ hostProps 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
	`addInfoProperty` (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
	`addInfoProperty` (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