summaryrefslogtreecommitdiff
path: root/Build/TestConfig.hs
blob: 9937f799f1b628442307c7616e3b8dbfb0a5bdc2 (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
{- Tests the system and generates Build.SysConfig.hs. -}

module Build.TestConfig where

import Utility.Path
import Utility.Monad

import System.IO
import System.Cmd
import System.Exit
import System.FilePath
import System.Directory

type ConfigKey = String
data ConfigValue =
	BoolConfig Bool |
	StringConfig String |
	MaybeStringConfig (Maybe String) |
	MaybeBoolConfig (Maybe Bool)
data Config = Config ConfigKey ConfigValue

type Test = IO Config
type TestName = String
data TestCase = TestCase TestName Test

instance Show ConfigValue where
	show (BoolConfig b) = show b
	show (StringConfig s) = show s
	show (MaybeStringConfig s) = show s
	show (MaybeBoolConfig s) = show s

instance Show Config where
	show (Config key value) = unlines
		[ key ++ " :: " ++ valuetype value
		, key ++ " = " ++ show value
		]
	  where
		valuetype (BoolConfig _) = "Bool"
		valuetype (StringConfig _) = "String"
		valuetype (MaybeStringConfig _) = "Maybe String"
		valuetype (MaybeBoolConfig _) = "Maybe Bool"

writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "Build/SysConfig.hs" body
  where
	body = unlines $ header ++ map show config ++ footer
	header = [
		  "{- Automatically generated. -}"
		, "module Build.SysConfig where"
		, ""
		]
	footer = []

runTests :: [TestCase] -> IO [Config]
runTests [] = return []
runTests (TestCase tname t : ts) = do
	testStart tname
	c <- t
	testEnd c
	rest <- runTests ts
	return $ c:rest

{- Tests that a command is available, aborting if not. -}
requireCmd :: ConfigKey -> String -> Test
requireCmd k cmdline = do
	ret <- testCmd k cmdline
	handle ret
  where
	handle r@(Config _ (BoolConfig True)) = return r
	handle r = do
		testEnd r
		error $ "** the " ++ c ++ " command is required"
	c = head $ words cmdline

{- Checks if a command is available by running a command line. -}
testCmd :: ConfigKey -> String -> Test
testCmd k cmdline = do
	ret <- system $ quiet cmdline
	return $ Config k (BoolConfig $ ret == ExitSuccess)

{- Ensures that one of a set of commands is available by running each in
 - turn. The Config is set to the first one found. -}
selectCmd :: ConfigKey -> [(String, String)] -> Test
selectCmd k = searchCmd
		(return . Config k . StringConfig)
		(\cmds -> do
			testEnd $ Config k $ BoolConfig False
			error $ "* need one of these commands, but none are available: " ++ show cmds
		)

maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test
maybeSelectCmd k = searchCmd
		(return . Config k . MaybeStringConfig . Just)
		(\_ -> return $ Config k $ MaybeStringConfig Nothing)

searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test
searchCmd success failure cmdsparams = search cmdsparams
  where
	search [] = failure $ fst $ unzip cmdsparams
	search ((c, params):cs) = do
		ret <- system $ quiet $ c ++ " " ++ params
		if ret == ExitSuccess
			then success c
			else search cs

{- Finds a command, either in PATH or perhaps in a sbin directory not in
 - PATH. If it's in PATH the config is set to just the command name,
 - but if it's found outside PATH, the config is set to the full path to
 - the command. -}
findCmdPath :: ConfigKey -> String -> Test
findCmdPath k command = do
	ifM (inPath command)
		( return $ Config k $ MaybeStringConfig $ Just command
		, do
			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]
			return $ Config k $ MaybeStringConfig r
		)
  where
	find d =
		let f = d </> command
		in ifM (doesFileExist f) ( return (Just f), return Nothing )

quiet :: String -> String
quiet s = s ++ " >/dev/null 2>&1"

testStart :: TestName -> IO ()
testStart s = do
	putStr $ "  checking " ++ s ++ "..."
	hFlush stdout

testEnd :: Config -> IO ()
testEnd (Config _ (BoolConfig True)) = status "yes"
testEnd (Config _ (BoolConfig False)) = status "no"
testEnd (Config _ (StringConfig s)) = status s
testEnd (Config _ (MaybeStringConfig (Just s))) = status s
testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"

status :: String -> IO ()
status s = putStrLn $ ' ':s