summaryrefslogtreecommitdiff
path: root/Property.hs
blob: ded40c4b49a0c866b4b3e4d5e5c7135f045256b0 (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
module Property where

import System.Directory
import Control.Applicative
import Control.Monad
import System.Console.ANSI
import System.Exit
import System.IO

import Utility.Tmp
import Utility.Exception
import Utility.SafeCommand
import Utility.Monad

-- Ensures that the system has some property. 
-- Actions must be idempotent; will be run repeatedly.
data Property
	= FileProperty Desc FilePath ([Line] -> [Line])
	| CmdProperty Desc String [CommandParam]
	| IOProperty Desc (IO Result)

data Result = NoChange | MadeChange | FailedChange
	deriving (Show, Eq)

type Line = String
type Desc = String

combineResult :: Result -> Result -> Result
combineResult FailedChange _ = FailedChange
combineResult _ FailedChange = FailedChange
combineResult MadeChange _ = MadeChange
combineResult _ MadeChange = MadeChange
combineResult NoChange NoChange = NoChange

propertyDesc :: Property -> Desc
propertyDesc (FileProperty d _ _) = d
propertyDesc (CmdProperty d _ _) = d
propertyDesc (IOProperty d _) = d

combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = IOProperty desc $ go ps NoChange
  where
  	go [] rs = return rs
	go (l:ls) rs = do
		r <- ensureProperty l
		case r of
			FailedChange -> return FailedChange
			_ -> go ls (combineResult r rs)

ensureProperty :: Property -> IO Result
ensureProperty = catchDefaultIO FailedChange . ensureProperty'

ensureProperty' :: Property -> IO Result
ensureProperty' (FileProperty _ f a) = go =<< doesFileExist f
  where
	go True = do
		ls <- lines <$> readFile f
		let ls' = a ls
		if ls' == ls
			then noChange
			else makeChange $ viaTmp writeFile f (unlines ls')
	go False = makeChange $ writeFile f (unlines $ a [])
ensureProperty' (CmdProperty _ cmd params) = ifM (boolSystem cmd params)
	( return MadeChange
	, return FailedChange
	)
ensureProperty' (IOProperty _ a) = a

ensureProperties :: [Property] -> IO ()
ensureProperties ps = do
	r <- ensure ps NoChange
	case r of
		FailedChange -> exitWith (ExitFailure 1)
		_ -> exitWith ExitSuccess
  where
	ensure [] rs = return rs
	ensure (l:ls) rs = do
		putStr $ propertyDesc l ++ "... "
		hFlush stdout
		r <- ensureProperty l
		case r of
			FailedChange -> do
				setSGR [SetColor Foreground Vivid Red]
				putStrLn "failed"
			NoChange -> do
				setSGR [SetColor Foreground Dull Green]
				putStrLn "(ok)"
			MadeChange -> do
				setSGR [SetColor Foreground Vivid Green]
				putStrLn "(ok)"
		setSGR []
		ensure ls (combineResult r rs)

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

noChange :: IO Result
noChange = return NoChange

cmdProperty :: String -> [CommandParam] -> Property
cmdProperty cmd params = CmdProperty desc cmd params
  where
  	desc = unwords $ cmd : map showp params
	showp (Params s) = s
	showp (Param s) = s
	showp (File s) = s

{- Replaces all the content of a file. -}
fileHasContent :: FilePath -> [Line] -> Property
fileHasContent f newcontent = FileProperty ("replace " ++ f)
	f (\_oldcontent -> newcontent)

{- Ensures that a line is present in a file, adding it to the end if not. -}
lineInFile :: FilePath -> Line -> Property
lineInFile f l = FileProperty (f ++ " contains:" ++ l) f go
  where
	go ls
		| l `elem` ls = ls
		| otherwise = ls++[l]

{- Ensures that a line is not present in a file.
 - Note that the file is ensured to exist, so if it doesn't, an empty
 - file will be written. -}
lineNotInFile :: FilePath -> Line -> Property
lineNotInFile f l = FileProperty (f ++ " remove: " ++ l) f (filter (/= l))

{- 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 -> FilePath -> Property
flagFile property flagfile = IOProperty (propertyDesc property) $
	go =<< doesFileExist flagfile
  where
	go True = return NoChange
	go False = do
		r <- ensureProperty property
		when (r == MadeChange) $
			writeFile flagfile ""
		return r

{- Whenever a change has to be made for a Property, causes a hook
 - Property to also be run, but not otherwise. -}
onChange :: Property -> Property -> Property
property `onChange` hook = IOProperty (propertyDesc property) $ do
	r <- ensureProperty property
	case r of
		MadeChange -> do
			r' <- ensureProperty hook
			return $ combineResult r r'
		_ -> return r

{- Makes a Property only be performed when a test succeeds. -}
check :: IO Bool -> Property -> Property
check c property = IOProperty (propertyDesc property) $ ifM c
	( ensureProperty property
	, return NoChange
	)