diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | TestConfig.hs | 93 | ||||
| -rw-r--r-- | configure.hs | 100 |
3 files changed, 105 insertions, 90 deletions
@@ -7,7 +7,7 @@ mans=git-annex.1 git-annex-shell.1 all: $(bins) $(mans) docs -SysConfig.hs: configure.hs +SysConfig.hs: configure.hs TestConfig.hs $(GHCMAKE) configure ./configure diff --git a/TestConfig.hs b/TestConfig.hs new file mode 100644 index 000000000..5e59681dd --- /dev/null +++ b/TestConfig.hs @@ -0,0 +1,93 @@ +{- Tests the system and generates SysConfig.hs. -} + +module TestConfig where + +import System.IO +import System.Cmd +import System.Exit + +type ConfigKey = String +data ConfigValue = BoolConfig Bool | StringConfig String +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 + +instance Show Config where + show (Config key value) = unlines + [ key ++ " :: " ++ valuetype value + , key ++ " = " ++ show value + ] + where + valuetype (BoolConfig _) = "Bool" + valuetype (StringConfig _) = "String" + +writeSysConfig :: [Config] -> IO () +writeSysConfig config = writeFile "SysConfig.hs" body + where + body = unlines $ header ++ map show config ++ footer + header = [ + "{- Automatically generated. -}" + , "module 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 = (words cmdline) !! 0 + +{- 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] -> Test +selectCmd k cmds = search cmds + where + search [] = do + testEnd $ Config k (BoolConfig False) + error $ "* need one of these commands, but none are available: " ++ show cmds + search (c:cs) = do + ret <- system $ quiet c + if (ret == ExitSuccess) + then return $ Config k (StringConfig 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)) = putStrLn $ " yes" +testEnd (Config _ (BoolConfig False)) = putStrLn $ " no" +testEnd (Config _ (StringConfig s)) = putStrLn $ " " ++ s diff --git a/configure.hs b/configure.hs index 9f50328d3..8d1c117a7 100644 --- a/configure.hs +++ b/configure.hs @@ -1,37 +1,17 @@ {- Checks system configuration and generates SysConfig.hs. -} -import System.IO -import System.Cmd -import System.Exit import System.Directory -type ConfigKey = String -data ConfigValue = BoolConfig Bool | StringConfig String -data Config = Config ConfigKey ConfigValue - -type Test = IO Config -type TestName = String -data TestCase = TestCase TestName Test - -instance Show Config where - show (Config key value) = unlines [ - key ++ " :: " ++ valuetype value - , key ++ " = " ++ showvalue value - ] - where - valuetype (BoolConfig _) = "Bool" - valuetype (StringConfig _) = "String" - showvalue (BoolConfig b) = show b - showvalue (StringConfig s) = show s +import TestConfig tests :: [TestCase] tests = [ - TestCase "cp -a" $ testCp "cp_a" "-a" - , TestCase "cp -p" $ testCp "cp_p" "-p" - , TestCase "cp --reflink=auto" $ testCp "cp_reflink_auto" "--reflink=auto" - , TestCase "uuid" $ selectCmd "uuid" ["uuid", "uuidgen"] - , TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0" "xargs -0 </dev/null" - , TestCase "rsync" $ requireCmd "rsync" "rsync" "rsync --version >/dev/null" + testCp "cp_a" "-a" + , testCp "cp_p" "-p" + , testCp "cp_reflink_auto" "--reflink=auto" + , TestCase "uuid generator" $ selectCmd "uuid" ["uuid", "uuidgen"] + , TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null" + , TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null" ] tmpDir :: String @@ -40,69 +20,11 @@ tmpDir = "tmp" testFile :: String testFile = tmpDir ++ "/testfile" -requireCmd :: ConfigKey -> String -> String -> Test -requireCmd k c 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 to use git-annex" - -testCp :: ConfigKey -> String -> Test -testCp k option = testCmd k $ - "cp " ++ option ++ " " ++ testFile ++ " " ++ testFile ++ ".new" - -testCmd :: ConfigKey -> String -> Test -testCmd k c = do - ret <- system $ quiet c - return $ Config k (BoolConfig $ ret == ExitSuccess) - -selectCmd :: ConfigKey -> [String] -> Test -selectCmd k cmds = search cmds +testCp :: ConfigKey -> String -> TestCase +testCp k option = TestCase cmd $ testCmd k run where - search [] = do - testEnd $ Config k (BoolConfig False) - error $ "* need one of these commands, but none are available: " ++ show cmds - search (c:cs) = do - ret <- system $ quiet c - if (ret == ExitSuccess) - then return $ Config k (StringConfig 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)) = putStrLn $ " yes" -testEnd (Config _ (BoolConfig False)) = putStrLn $ " no" -testEnd (Config _ (StringConfig s)) = putStrLn $ " " ++ s - -writeSysConfig :: [Config] -> IO () -writeSysConfig config = writeFile "SysConfig.hs" body - where - body = unlines $ header ++ map show config ++ footer - header = [ - "{- Automatically generated by configure. -}" - , "module 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 + cmd = "cp " ++ option + run = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new" setup :: IO () setup = do |