9cdbfa764e
So, it might be called sha1sum, or on some other OS, it might be called sha1. It might be hidden away off of PATH on that OS. That's just expected insanity; UNIX has been this way since 1980's. And these days, nobody even gives the flying flip about standards that we briefly did in the 90's after the first round of unix wars. But it's the 2010's now, and we've certainly learned something. So, let's make it so sometimes sha1 is a crazy program that wants to run as root so it can lock memory while prompting for a passphrase, and outputting binary garbage. Yes, that'd be wise. Let's package that in major Linux distros, too, so users can stumble over it.
120 lines
3.5 KiB
Haskell
120 lines
3.5 KiB
Haskell
{- Tests the system and generates Build.SysConfig.hs. -}
|
|
|
|
module Build.TestConfig where
|
|
|
|
import System.IO
|
|
import System.Cmd
|
|
import System.Exit
|
|
|
|
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
|
|
|
|
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
|