refactor
This commit is contained in:
Joey Hess
parent
dbb76c22d0
commit
4465689cc2
3 changed files with 105 additions and 90 deletions
2
Makefile
2
Makefile
|
|
@ -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
|
||||
|
||||
|
|
|
|||
93
TestConfig.hs
Normal file
93
TestConfig.hs
Normal file
|
|
@ -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
|
||||
100
configure.hs
100
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
|
||||
testCp :: ConfigKey -> String -> TestCase
|
||||
testCp k option = TestCase cmd $ testCmd k run
|
||||
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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue