Spin.hs

{-# 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