summaryrefslogtreecommitdiff
path: root/src/Propellor/Types.hs
blob: e10e0f5ba72517691882c61d8e1b7af03bc18edd (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
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Propellor.Types (
	-- * Core data types
	  Host(..)
	, Property(..)
	, property
	, property''
	, Desc
	, RevertableProperty(..)
	, (<!>)
	, Propellor(..)
	, LiftPropellor(..)
	, Info
	-- * Types of properties
	, UnixLike
	, Linux
	, DebianLike
	, Debian
	, Buntish
	, ArchLinux
	, FreeBSD
	, HasInfo
	, type (+)
	, TightenTargets(..)
	-- * Combining and modifying properties
	, Combines(..)
	, CombinedType
	, ResultCombiner
	, adjustPropertySatisfy
	-- * Other included types
	, module Propellor.Types.OS
	, module Propellor.Types.ConfigurableValue
	, module Propellor.Types.Dns
	, module Propellor.Types.Result
	, module Propellor.Types.ZFS
	) where

import qualified Data.Semigroup as Sem
import Data.Monoid
import Control.Applicative
import Prelude

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

-- | The core data type of Propellor, this represents a property
-- that the system should have, with a descrition, and an action to ensure
-- it has the property.
--
-- There are different types of properties that target different OS's,
-- and so have different metatypes. 
-- For example: "Property DebianLike" and "Property FreeBSD".
--
-- Also, some properties have associated `Info`, which is indicated in
-- their type: "Property (HasInfo + DebianLike)"
--
-- There are many associated type families, which are mostly used
-- internally, so you needn't worry about them.
data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty]

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

-- | Constructs a Property, from a description and an action to run to
-- ensure the Property is met.
--
-- Due to the polymorphic return type of this function, most uses will need
-- to specify a type signature. This lets you specify what OS the property
-- targets, etc.
--
-- For example:
--
-- > foo :: Property Debian
-- > foo = property "foo" $ do
-- >	...
-- > 	return MadeChange
property
	:: SingI metatypes
	=> Desc
	-> Propellor Result
	-> Property (MetaTypes metatypes)
property d a = Property sing d (Just a) mempty mempty

property''
	:: SingI metatypes
	=> Desc
	-> Maybe (Propellor Result)
	-> Property (MetaTypes metatypes)
property'' d a = Property sing d a mempty mempty

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

-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
--
-- See `Propellor.Property.Versioned.Versioned` 
-- for a way to use RevertableProperty to define different
-- versions of a host.
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

instance IsProp (Property metatypes) where
	setDesc (Property t _ a i c) d = Property t d a i c
	getDesc (Property _ d _ _ _) = d
	getChildren (Property _ _ _ _ c) = c
	addChildren (Property t d a i c) c' = Property t d a i (c ++ c')
	getInfoRecursive (Property _ _ _ i c) =
		i <> mconcat (map getInfoRecursive c)
	getInfo (Property _ _ _ i _) = i
	toChildProperty (Property _ d a i c) = ChildProperty d a i c
	getSatisfy (Property _ _ a _ _) = a

instance IsProp (RevertableProperty setupmetatypes undometatypes) where
	-- | Sets the description of both sides.
	setDesc (RevertableProperty p1 p2) d =
		RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
	getDesc (RevertableProperty p1 _) = getDesc p1
	getChildren (RevertableProperty p1 _) = getChildren p1
	-- | Only add children to the active side.
	addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2
	-- | Return the Info of the currently active side.
	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
	getInfo (RevertableProperty p1 _p2) = getInfo p1
	toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
	getSatisfy (RevertableProperty p1 _) = getSatisfy p1

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

type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (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 (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
	combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =
		Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1)
instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
	combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
		RevertableProperty
			(combineWith sf tf s1 s2)
			(combineWith tf sf t1 t2)
instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
	combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
	combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y

class TightenTargets p where
	-- | Tightens the MetaType list of a Property (or similar),
	-- to contain fewer targets.
	--
	-- For example, to make a property that uses apt-get, which is only
	-- available on DebianLike systems:
	--
	-- > upgraded :: Property DebianLike
	-- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
	tightenTargets
		:: 
			-- Note that this uses PolyKinds
			( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
			, (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
			, SingI tightened
			)
		=> p (MetaTypes untightened)
		-> p (MetaTypes tightened)

instance TightenTargets Property where
	tightenTargets (Property _ d a i c) = Property sing d a i c

-- | Any type of Property is a Semigroup. When properties x and y are
-- appended together, the resulting property has a description like
-- "x and y". Note that when x fails to be ensured, it will not
-- try to ensure y.
instance SingI metatypes => Sem.Semigroup (Property (MetaTypes metatypes))
  where
	Property _ d1 a1 i1 c1 <> Property _ d2 a2 i2 c2 =
	  	Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2)
	  where
		-- Avoid including "noop property" in description
		-- when using eg mconcat.
		d = case (a1, a2) of
			(Just _, Just _) -> d1 <> " and " <> d2
			(Just _, Nothing) -> d1
			(Nothing, Just _) -> d2
			(Nothing, Nothing) -> d1

-- | Any type of Property is a Monoid.
instance SingI metatypes => Monoid (Property (MetaTypes metatypes))
  where
	-- | A property that does nothing.
	mempty = Property sing "noop property" Nothing mempty mempty
	mappend = (Sem.<>)

-- | Any type of RevertableProperty is a Semigroup. When revertable 
-- properties x and y are appended together, the resulting revertable
-- property has a description like "x and y".
-- Note that when x fails to be ensured, it will not try to ensure y.
instance
	( Sem.Semigroup (Property (MetaTypes setupmetatypes))
	, Sem.Semigroup (Property (MetaTypes undometatypes))
	, SingI setupmetatypes
	, SingI undometatypes
	)
	=> Sem.Semigroup (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))
  where
	RevertableProperty s1 u1 <> RevertableProperty s2 u2 =
		RevertableProperty (s1 <> s2) (u2 <> u1)

instance
	( Monoid (Property (MetaTypes setupmetatypes))
	, Monoid (Property (MetaTypes undometatypes))
	, SingI setupmetatypes
	, SingI undometatypes
	)
	=> Monoid (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))
  where
	mempty = RevertableProperty mempty mempty
	mappend = (Sem.<>)