summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Conductor.hs
blob: cfeb5aa7ff9b6967bd7c7c239e091b5c7ec41c6b (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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
{-# 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 _ = PropagateInfo False
instance IsInfo NotConductorFor where
	propagateInfo _ = PropagateInfo False

-- Added to Info when a host has been orchestrated.
newtype Orchestrated = Orchestrated Any
	deriving (Typeable, Monoid, Show)
instance IsInfo Orchestrated where
	propagateInfo _ = PropagateInfo False

isOrchestrated :: Orchestrated -> Bool
isOrchestrated (Orchestrated v) = getAny v