143 lines
4.2 KiB
Haskell
143 lines
4.2 KiB
Haskell
{- Tests the system and generates Build.SysConfig.hs. -}
|
|
|
|
module Build.TestConfig where
|
|
|
|
import Utility.Path
|
|
import Utility.Monad
|
|
import Utility.SafeCommand
|
|
|
|
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
|
|
ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]
|
|
return $ Config k (BoolConfig ok)
|
|
|
|
{- 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
|
|
ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]
|
|
if ok
|
|
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
|