summaryrefslogtreecommitdiff
path: root/src/Propellor/Types.hs
blob: 6c1412c1fe2482fcb9e38bbe40bf40b0d62cfb3d (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
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}

module Propellor.Types
	( Host(..)
	, Property
	, Info
	, Desc
	, mkProperty
	, MetaType(..)
	, OS(..)
	, UnixLike
	, Debian
	, Buntish
	, FreeBSD
	, HasInfo
	, type (+)
	, addInfoProperty
	, adjustPropertySatisfy
	, propertyInfo
	, propertyDesc
	, propertyChildren
	, RevertableProperty(..)
	, IsProp(..)
	, Combines(..)
	, CombinedType
	, ResultCombiner
	, Propellor(..)
	, LiftPropellor(..)
	, EndAction(..)
	, module Propellor.Types.OS
	, module Propellor.Types.Dns
	, module Propellor.Types.Result
	, module Propellor.Types.ZFS
	, propertySatisfy
	) where

import Data.Monoid
import "mtl" Control.Monad.RWS.Strict
import Control.Monad.Catch
import Data.Typeable
import Control.Applicative
import Prelude

import Propellor.Types.Info
import Propellor.Types.OS
import Propellor.Types.Dns
import Propellor.Types.Result
import Propellor.Types.MetaTypes
import Propellor.Types.ZFS

-- | Everything Propellor knows about a system: Its hostname,
-- properties and their collected info.
data Host = Host
	{ hostName :: HostName
	, hostProperties :: [ChildProperty]
	, hostInfo :: Info
	}
	deriving (Show, Typeable)

-- | Propellor's monad provides read-only access to info about the host
-- it's running on, and a writer to accumulate EndActions.
newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
	deriving
		( Monad
		, Functor
		, Applicative
		, MonadReader Host
		, MonadWriter [EndAction]
		, MonadIO
		, MonadCatch
		, MonadThrow
		, MonadMask
		)

class LiftPropellor m where
	liftPropellor :: m a -> Propellor a

instance LiftPropellor Propellor where
	liftPropellor = id

instance LiftPropellor IO where
	liftPropellor = liftIO

instance Monoid (Propellor Result) where
	mempty = return NoChange
	-- | The second action is only run if the first action does not fail.
	mappend x y = do
		rx <- x
		case rx of
			FailedChange -> return FailedChange
			_ -> do
				ry <- y
				return (rx <> ry)

-- | An action that Propellor runs at the end, after trying to satisfy all
-- properties. It's passed the combined Result of the entire Propellor run.
data EndAction = EndAction Desc (Result -> Propellor Result)

type Desc = String

-- | The core data type of Propellor, this represents a property
-- that the system should have, with a descrition, an action to ensure
-- it has the property, and perhaps some Info that can be added to Hosts
-- that have the property.
--
-- A property has a list of `[MetaType]`, which is part of its type.
--
-- There are many instances and type families, which are mostly used
-- internally, so you needn't worry about them.
data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]

-- | Since there are many different types of Properties, they cannot be put
-- into a list. The simplified ChildProperty can be put into a list.
data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]

instance Show ChildProperty where
	show (ChildProperty desc _ _ _) = desc

-- | Constructs a Property.
--
-- You can specify any metatypes that make sense to indicate what OS
-- the property targets, etc.
--
-- For example:
--
-- > foo :: Property Debian
-- > foo = mkProperty "foo" (...)
--
-- Note that using this needs LANGUAGE PolyKinds.
mkProperty
	:: SingI metatypes
	=> Desc
	-> Propellor Result
	-> Property (Sing metatypes)
mkProperty d a = Property sing d a mempty mempty

-- | Adds info to a Property.
--
-- The new Property will include HasInfo in its metatypes.
addInfoProperty
	:: (metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
	=> Property metatypes
	-> Info
	-> Property (Sing metatypes')
addInfoProperty (Property metatypes d a i c) newi = Property sing d a (i <> newi) c

{-

-- | Makes a version of a Proprty without its Info.
-- Use with caution!
ignoreInfo
	:: (metatypes' ~ 
	=> Property metatypes
	-> Property (Sing metatypes')
ignoreInfo = 

-}

-- | Gets the action that can be run to satisfy a Property.
-- You should never run this action directly. Use
-- 'Propellor.Engine.ensureProperty` instead.
propertySatisfy :: Property metatypes -> Propellor Result
propertySatisfy (Property _ _ a _ _) = a

-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c

propertyInfo :: Property metatypes -> Info
propertyInfo (Property _ _ _ i _) = i

propertyDesc :: Property metatypes -> Desc
propertyDesc (Property _ d _ _ _) = d

instance Show (Property metatypes) where
	show p = "property " ++ show (propertyDesc p)

-- | A Property can include a list of child properties that it also
-- satisfies. This allows them to be introspected to collect their info, etc.
propertyChildren :: Property metatypes -> [ChildProperty]
propertyChildren (Property _ _ _ _ c) = c

-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
data RevertableProperty setupmetatypes undometatypes = RevertableProperty
	{ setupRevertableProperty :: Property setupmetatypes
	, undoRevertableProperty :: Property undometatypes
	}

instance Show (RevertableProperty setupmetatypes undometatypes) where
	show (RevertableProperty p _) = show p

-- | Shorthand to construct a revertable property from any two Properties.
(<!>)
	:: Property setupmetatypes
	-> Property undometatypes
	-> RevertableProperty setupmetatypes undometatypes
setup <!> undo = RevertableProperty setup undo

-- | Class of types that can be used as properties of a host.
class IsProp p where
	setDesc :: p -> Desc -> p
	-- toProp :: p -> Property HasInfo
	getDesc :: p -> Desc
	-- | Gets the info of the property, combined with all info
	-- of all children properties.
	getInfoRecursive :: p -> Info

instance IsProp (Property metatypes) where
	setDesc (Property t _ a i c) d = Property t d a i c
	-- toProp = id
	getDesc = propertyDesc
	getInfoRecursive (Property _ _ _ i c) =
		i <> mconcat (map getInfoRecursive c)

instance IsProp ChildProperty where
	setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
	getDesc (ChildProperty d _ _ _) = d
	getInfoRecursive (ChildProperty _ _ i c) =
		i <> mconcat (map getInfoRecursive c)

instance IsProp (RevertableProperty setupmetatypes undometatypes) where
	setDesc = setDescR
	getDesc (RevertableProperty p1 _) = getDesc p1
	-- toProp (RevertableProperty p1 _) = p1
	-- | Return the Info of the currently active side.
	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1

-- | Sets the description of both sides.
setDescR :: IsProp (Property setupmetatypes) => RevertableProperty setupmetatypes undometatypes -> Desc -> RevertableProperty setupmetatypes undometatypes
setDescR (RevertableProperty p1 p2) d =
	RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))

-- | Type level calculation of the type that results from combining two
-- types of properties.
type family CombinedType x y
type instance CombinedType (Property (Sing x)) (Property (Sing y)) = Property (Sing (Union x y))
type instance CombinedType (RevertableProperty (Sing x) (Sing x')) (RevertableProperty (Sing y) (Sing y')) = RevertableProperty (Sing (Union x y)) (Sing (Union x' y'))
-- When only one of the properties is revertable, the combined property is
-- not fully revertable, so is not a RevertableProperty.
type instance CombinedType (RevertableProperty (Sing x) (Sing x')) (Property (Sing y)) = Property (Sing (Union x y))
type instance CombinedType (Property (Sing x)) (RevertableProperty (Sing y) (Sing y')) = Property (Sing (Union x y))

type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result

class Combines x y where
	-- | Combines together two properties, yielding a property that
	-- has the description and info of the first, and that has the
	-- second property as a child property.
	combineWith
		:: ResultCombiner
		-- ^ How to combine the actions to satisfy the properties.
		-> ResultCombiner
		-- ^ Used when combining revertable properties, to combine
		-- their reversion actions.
		-> x
		-> y
		-> CombinedType x y

instance (CombinedType (Property (Sing x)) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (Property (Sing y)) where
	combineWith f _ (Property t1 d1 a1 i1 c1) (Property _t2 d2 a2 i2 c2) =
		Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1)
instance (CombinedType (RevertableProperty (Sing x) (Sing x')) (RevertableProperty (Sing y) (Sing y')) ~ RevertableProperty (Sing (Union x y)) (Sing (Union x' y')), SingI (Union x y), SingI (Union x' y')) => Combines (RevertableProperty (Sing x) (Sing x')) (RevertableProperty (Sing y) (Sing y')) where
	combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
		RevertableProperty
			(combineWith sf tf s1 s2)
			(combineWith tf sf t1 t2)
instance (CombinedType (RevertableProperty (Sing x) (Sing x')) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (RevertableProperty (Sing x) (Sing x')) (Property (Sing y)) where
	combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
instance (CombinedType (Property (Sing x)) (RevertableProperty (Sing y) (Sing y')) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (RevertableProperty (Sing y) (Sing y')) where
	combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y