summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Spin.hs
blob: ead85f59dd2baef6a6fe64c2eea440ae4c7f60fa (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

module Propellor.Property.Spin (
	Spinnable(..),
	controllerFor,
	controllerKeys,
	controlledBy,
) where

import Propellor.Base
import Propellor.Spin (spin)
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) []
		`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 (hostName h) Nothing 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

-- | 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 `controllerKey`
-- 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.
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)

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