summaryrefslogtreecommitdiff
path: root/src/Propellor/Property.hs
blob: ae4fc914c5b19cc1112f8d9637b436aaa7c647c9 (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
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}

module Propellor.Property (
	-- * Property combinators
	  requires
	, before
	, onChange
	, onChangeFlagOnFail
	, flagFile
	, flagFile'
	, check
	, fallback
	, revert
	, applyToList
	-- * Property descriptions
	, describe
	, (==>)
	-- * Constructing properties
	, Propellor
	, property
	, property'
	, OuterMetaTypesWitness
	, ensureProperty
	, pickOS
	, withOS
	, unsupportedOS
	, unsupportedOS'
	, makeChange
	, noChange
	, doNothing
	, endAction
	-- * Property result checking
	, UncheckedProperty
	, unchecked
	, changesFile
	, changesFileContent
	, isNewerThan
	, checkResult
	, Checkable
	, assume
) where

import System.FilePath
import Control.Monad
import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
import qualified Data.Hash.MD5 as MD5
import Data.List
import Control.Applicative
import Data.Foldable hiding (and, elem)
import Prelude

import Propellor.Types
import Propellor.Types.Core
import Propellor.Types.ResultCheck
import Propellor.Types.MetaTypes
import Propellor.Types.Singletons
import Propellor.Info
import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Misc
import Utility.Directory

-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
flagFile :: Property i -> FilePath -> Property i
flagFile p = flagFile' p . return

flagFile' :: Property i -> IO FilePath -> Property i
flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
	flagfile <- liftIO getflagfile
	go satisfy flagfile =<< liftIO (doesFileExist flagfile)
  where
	go _ _ True = return NoChange
	go satisfy flagfile False = do
		r <- satisfy
		when (r == MadeChange) $ liftIO $
			unlessM (doesFileExist flagfile) $ do
				createDirectoryIfMissing True (takeDirectory flagfile)
				writeFile flagfile ""
		return r

-- | Indicates that the first property depends on the second,
-- so before the first is ensured, the second must be ensured.
--
-- The combined property uses the description of the first property.
requires :: Combines x y => x -> y -> CombinedType x y
requires = combineWith
	-- Run action of y, then x
	(flip (<>))
	-- When reverting, run in reverse order.
	(<>)

-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
--
-- The combined property uses the description of the first property.
before :: Combines x y => x -> y -> CombinedType x y
before = combineWith
	-- Run action of x, then y
	(<>)
	-- When reverting, run in reverse order.
	(flip (<>))

-- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange
	:: (Combines x y)
	=> x
        -> y
        -> CombinedType x y
onChange = combineWith combiner revertcombiner
  where
	combiner p hook = do
		r <- p
		case r of
			MadeChange -> do
				r' <- hook
				return $ r <> r'
			_ -> return r
	revertcombiner = (<>)

-- | Same as `onChange` except that if property y fails, a flag file
-- is generated. On next run, if the flag file is present, property y
-- is executed even if property x doesn't change.
--
-- With `onChange`, if y fails, the property x `onChange` y returns
-- `FailedChange`. But if this property is applied again, it returns
-- `NoChange`. This behavior can cause trouble...
onChangeFlagOnFail
	:: (Combines x y)
	=> FilePath
        -> x
        -> y
        -> CombinedType x y
onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
  where
	combiner s1 s2 = do
		r1 <- s1
		case r1 of
			MadeChange -> flagFailed s2
			_ -> ifM (liftIO $ doesFileExist flagfile)
				(flagFailed s2
				, return r1
				)
	revertcombiner = (<>)
	flagFailed s = do
		r <- s
		liftIO $ case r of
			FailedChange -> createFlagFile
			_ -> removeFlagFile
		return r
	createFlagFile = unlessM (doesFileExist flagfile) $ do
		createDirectoryIfMissing True (takeDirectory flagfile)
		writeFile flagfile ""
	removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile

-- | Changes the description of a property.
describe :: IsProp p => p -> Desc -> p
describe = setDesc

-- | Alias for @flip describe@
(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
(==>) = flip describe
infixl 1 ==>

-- | Tries the first property, but if it fails to work, instead uses
-- the second.
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
fallback = combineWith combiner revertcombiner
  where
	combiner a1 a2 = do
		r <- a1
		if r == FailedChange
			then a2
			else return r
	revertcombiner = (<>)

-- | Indicates that a Property may change a particular file. When the file
-- is modified in any way (including changing its permissions or mtime),
-- the property will return MadeChange instead of NoChange.
changesFile :: Checkable p i => p i -> FilePath -> Property i
changesFile p f = checkResult getstat comparestat p
  where
	getstat = catchMaybeIO $ getSymbolicLinkStatus f
	comparestat oldstat = do
		newstat <- getstat
		return $ if samestat oldstat newstat then NoChange else MadeChange
	samestat Nothing Nothing = True
	samestat (Just a) (Just b) = and
		-- everything except for atime
		[ deviceID a == deviceID b
		, fileID a == fileID b
		, fileMode a == fileMode b
		, fileOwner a == fileOwner b
		, fileGroup a == fileGroup b
		, specialDeviceID a == specialDeviceID b
		, fileSize a == fileSize b
		, modificationTimeHiRes a == modificationTimeHiRes b
		, isBlockDevice a == isBlockDevice b
		, isCharacterDevice a == isCharacterDevice b
		, isNamedPipe a == isNamedPipe b
		, isRegularFile a == isRegularFile b
		, isDirectory a == isDirectory b
		, isSymbolicLink a == isSymbolicLink b
		, isSocket a == isSocket b
		]
	samestat _ _ = False

-- | Like `changesFile`, but compares the content of the file.
-- Changes to mtime etc that do not change file content are treated as
-- NoChange.
changesFileContent :: Checkable p i => p i -> FilePath -> Property i
changesFileContent p f = checkResult getmd5 comparemd5 p
  where
	getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f
	comparemd5 oldmd5 = do
		newmd5 <- getmd5
		return $ if oldmd5 == newmd5 then NoChange else MadeChange

-- | Determines if the first file is newer than the second file.
--
-- This can be used with `check` to only run a command when a file
-- has changed.
--
-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
-- > 	(cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db
--
-- Or it can be used with `checkResult` to test if a command made a change.
--
-- > checkResult (return ())
-- > 	(\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases")
-- > 	(cmdProperty "newaliases" [])
--
-- (If one of the files does not exist, the file that does exist is
-- considered to be the newer of the two.)
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan x y = do
	mx <- mtime x
	my <- mtime y
	return (mx > my)
  where
	mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f

-- | Picks one of the two input properties to use,
-- depending on the targeted OS.
--
-- If both input properties support the targeted OS, then the
-- first will be used.
--
-- The resulting property will use the description of the first property
-- no matter which property is used in the end. So, it's often a good
-- idea to change the description to something clearer.
--
-- For example:
--
-- > upgraded :: UnixLike
-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
-- > 	`describe` "OS upgraded"
--
-- If neither input property supports the targeted OS, calls
-- `unsupportedOS`. Using the example above on a Fedora system would
-- fail that way.
pickOS
	::
		( SingKind ('KProxy :: KProxy ka)
		, SingKind ('KProxy :: KProxy kb)
		, DemoteRep ('KProxy :: KProxy ka) ~ [MetaType]
		, DemoteRep ('KProxy :: KProxy kb) ~ [MetaType]
		, SingI c
		-- Would be nice to have this constraint, but
		-- union will not generate metatypes lists with the same
		-- order of OS's as is used everywhere else. So,
		-- would need a type-level sort.
		--, Union a b ~ c
		)
	=> Property (MetaTypes (a :: ka))
	-> Property (MetaTypes (b :: kb))
	-> Property (MetaTypes c)
pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
  where
	-- This use of getSatisfy is safe, because both a and b
	-- are added as children, so their info will propigate.
	c = withOS (getDesc a) $ \_ o ->
		if matching o a
			then getSatisfy a
			else if matching o b
				then getSatisfy b
				else unsupportedOS'
	matching Nothing _ = False
	matching (Just o) p =
		Targeting (systemToTargetOS o)
			`elem`
		fromSing (proptype p)
	proptype (Property t _ _ _ _) = t

-- | Makes a property that is satisfied differently depending on specifics
-- of the host's operating system.
--
-- > myproperty :: Property Debian
-- > myproperty = withOS "foo installed" $ \w o -> case o of
-- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
-- > 	(Just (System (Debian suite) arch)) -> ensureProperty w ...
-- >	_ -> unsupportedOS'
--
-- Note that the operating system specifics may not be declared for all hosts,
-- which is where Nothing comes in.
withOS
	:: (SingI metatypes)
	=> Desc
	-> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)
	-> Property (MetaTypes metatypes)
withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
  where
	-- Using this dummy value allows ensureProperty to be used
	-- even though the inner property probably doesn't target everything
	-- that the outer withOS property targets.
	dummyoutermetatypes :: OuterMetaTypesWitness ('[])
	dummyoutermetatypes = OuterMetaTypesWitness sing

-- | A property that always fails with an unsupported OS error.
unsupportedOS :: Property UnixLike
unsupportedOS = property "unsupportedOS" unsupportedOS'

-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
unsupportedOS' :: Propellor Result
unsupportedOS' = go =<< getOS
	  where
		go Nothing = error "Unknown host OS is not supported by this property."
		go (Just o) = error $ "This property is not implemented for " ++ show o

-- | Undoes the effect of a RevertableProperty.
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1

-- | Apply a property to each element of a list.
applyToList
	:: (Foldable t, Functor t, Combines p p, p ~ CombinedType p p)
	=> (b -> p)
	-> t b
	-> p
prop `applyToList` xs = Data.Foldable.foldr1 before $ prop <$> xs

makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange

noChange :: Propellor Result
noChange = return NoChange

doNothing :: SingI t => Property (MetaTypes t)
doNothing = property "noop property" noChange

-- | Registers an action that should be run at the very end, after
-- propellor has checks all the properties of a host.
endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()
endAction desc a = tell [EndAction desc a]