summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/ControlHeir.hs
blob: 9fd2ce43967c8f31f6cdf4715a12b6e0f623eb19 (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
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

module Propellor.Property.ControlHeir (
	ControlHeir(..),
	ControlList(..),
	addControlHeir,
	ControllerOf(..),
) where

import Propellor.Base
import Propellor.Spin (spin')
import Propellor.PrivData.Paths
import Propellor.Types.Info
import qualified Propellor.Property.Ssh as Ssh

-- | A hierarchy of control. When propellor is run on a host that
-- is a Controller, it in turn spins each of the hosts in its control
-- list.
--
-- There can be multiple levels of controllers in the hierarchy.
--
-- Multiple controllers can control the same hosts. However, when
-- propellor is already running on a host, a controller will fail
-- to spin it. So, if two controllers both try to control the same
-- host at the same time, one will fail.
-- 
-- (Loops in the hierarchy, such as a host controlling itself,
-- are detected and automatically broken.)
data ControlHeir
	= Controller Host ControlList
	| Controlled Host

instance Show ControlHeir where
	show (Controller h l) = "Controller " ++ hostName h ++ " (" ++ show l ++ ")"
	show (Controlled h) = "Controlled " ++ hostName h

data ControlList
	-- | A list of hosts to control. Failure to spin one host does not
	-- prevent spinning later hosts in the list.
	= ControlList [ControlHeir]
	-- | Requires the first host to be successfully spinned before
	-- proceeding to spin the hosts in the ControlList.
	| ControlReq ControlHeir ControlList
	deriving (Show)

listHeir :: ControlList -> [ControlHeir]
listHeir (ControlList l) = l
listHeir (ControlReq h l) = h : listHeir l

class DirectlyControlled a where
	directlyControlled :: a -> [Host]

instance DirectlyControlled ControlHeir where
	directlyControlled (Controlled h) = [h]
	directlyControlled (Controller h _) = [h]

instance DirectlyControlled ControlList where
	directlyControlled = concatMap directlyControlled . listHeir

-- Removes any loops that may be present in the ControlHeir involving
-- the passed Host. This is a simple matter of removing the Host from any
-- sub-hierarchies.
deloop :: Host -> ControlHeir -> ControlHeir
deloop _ (Controlled h) = Controlled h
deloop thehost (Controller h cl) = Controller h (removeh cl)
  where
	removeh (ControlList l) = ControlList (mapMaybe removeh' l)
	removeh (ControlReq ch cl') = case removeh' ch of
		Just ch' -> ControlReq ch' (removeh cl')
		Nothing -> removeh cl'
	removeh' (Controlled h')
		| hostName h' == hostName thehost = Nothing
		| otherwise = Just (Controlled h')
	removeh' (Controller h' cl')
		| hostName h' == hostName thehost = Nothing
		| otherwise = Just (Controller h' (removeh cl'))

-- | Applies a ControlHeir to a list of hosts.
--
-- This 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 each of the controlled Hosts.
--
-- The controller needs to be able to ssh to the hosts it controls,
-- and run propellor, as root. To this end, 
-- the `Propellor.Property.Ssh.knownHost` property is added to the
-- controller, so it knows the host keys of the hosts it controlls.
--
-- Each controlled host is configured to let its controller
-- ssh in as root. This is done by adding the 
-- `Propellor.Property.Ssh.authorizedKeysFrom` property, with
-- `User "root"`.
--
-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to
-- configure the ssh keys for the root user on controller hosts,
-- and to use `Ssh.hostKeys` to configure the host keys for the controlled
-- hosts.
--
-- For example, if you have some webservers and a dnsserver,
-- and want a master that runs propellor on all of them:
--
-- > import Propellor
-- > import Propellor.Property.ControlHeir
-- > import qualified Propellor.Property.Ssh as Ssh
-- > import qualified Propellor.Property.Cron as Cron
-- > 
-- > main = defaultMain (hosts `addControlHeir` control)
-- >
-- > hosts =
-- > 	[ master
-- >	, dnsserver
-- >	] ++ webservers
-- > 
-- > control = Controller master (ControlList (map Controlled (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")]
-- >	& Cron.runPropellor
--
-- Note that a controller can see all PrivData of the hosts below it in
-- the ControlHeir.
addControlHeir :: [Host] -> ControlHeir -> [Host]
addControlHeir hs (Controlled _) = hs
addControlHeir hs c@(Controller _ _)
	| any isController hs = error "Detected repeated applications of addControlHeir. Since loop prevention only works within a single application, repeated application is unsafe and not allowed."
	| otherwise = map (\h -> addControlHeir' h (deloop h c)) hs

-- Walk through the ControlHeir, and add properties to the Host
-- depending on where it appears in the ControlHeir.
-- (Loops are already removed before this point.)
addControlHeir' :: Host -> ControlHeir -> Host
addControlHeir' h (Controlled _) = h
addControlHeir' h (Controller controller l)
	| hn == hostName controller = cont $
		h & mkcontroller l
	| hn `elem` map hostName (directlyControlled l) = cont $
		h & controlledBy controller
	| otherwise = cont h
  where
	hn = hostName h

	cont h' = foldl addControlHeir' h' (listHeir l)
	
	mkcontroller (ControlList l') =
		mkcontroller' (concatMap directlyControlled l')
	mkcontroller (ControlReq h' l') =
		mkcontroller' (directlyControlled h')
			`before` mkcontroller l' 
	mkcontroller' l' = propertyList
		(cdesc $ unwords $ map hostName l')
		(map controllerFor l')

-- | The host this property is added to becomes the controller for the
-- specified Host.
controllerFor :: Host -> Property HasInfo
controllerFor h = infoProperty desc go (mkControllingInfo h <> privinfo) []
	`requires` Ssh.knownHost [h] (hostName h) (User "root")
	`requires` Ssh.installed
  where
	desc = cdesc (hostName h)

	-- 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)

	go = do
		pm <- liftIO $ filterPrivData h . readPrivData
			<$> readFileStrictAnyEncoding 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

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

-- | A Host's Info contains a list of the names of hosts it's controlling.
newtype ControllerOf = ControllerOf [HostName]
	deriving (Typeable, Monoid, Show)

instance IsInfo ControllerOf where
	propagateInfo _ = True

mkControllingInfo :: Host -> Info
mkControllingInfo controlled = addInfo mempty (ControllerOf [hostName controlled])

isController :: Host -> Bool
isController h = case getInfo (hostInfo h) of
	ControllerOf [] -> False
	_ -> True