96 lines
2.1 KiB
Haskell
96 lines
2.1 KiB
Haskell
{- Checks system configuration and generates SysConfig.hs. -}
|
|
|
|
import System.IO
|
|
import System.Cmd
|
|
import System.Exit
|
|
import System.Directory
|
|
|
|
type Test = IO Bool
|
|
data TestCase = TestCase String String Test
|
|
data Config = Config String Bool
|
|
|
|
instance Show Config where
|
|
show (Config key value) = unlines [
|
|
key ++ " :: Bool"
|
|
, key ++ " = " ++ show value
|
|
]
|
|
|
|
tests :: [TestCase]
|
|
tests = [
|
|
TestCase "cp -a" "cp_a" $ testCp "-a"
|
|
, TestCase "cp -p" "cp_p" $ testCp "-p"
|
|
, TestCase "cp --reflink=auto" "cp_reflink_auto" $ testCp "--reflink=auto"
|
|
, TestCase "uuid" "uuid" $ requireCommand "uuid" "uuid"
|
|
, TestCase "xargs -0" "xargs_0" $ requireCommand "xargs -0" "xargs -0 </dev/null"
|
|
]
|
|
|
|
tmpDir :: String
|
|
tmpDir = "tmp"
|
|
|
|
testFile :: String
|
|
testFile = tmpDir ++ "/testfile"
|
|
|
|
quiet :: String -> String
|
|
quiet s = s ++ " >/dev/null 2>&1"
|
|
|
|
requireCommand :: String -> String -> Test
|
|
requireCommand command cmdline = do
|
|
ret <- testCmd $ quiet cmdline
|
|
if ret
|
|
then return True
|
|
else do
|
|
testEnd False
|
|
error $ "** the " ++ command ++ " command is required to use git-annex"
|
|
|
|
testCp :: String -> Test
|
|
testCp option = testCmd $ quiet $ "cp " ++ option ++ " " ++ testFile ++
|
|
" " ++ testFile ++ ".new"
|
|
|
|
testCmd :: String -> Test
|
|
testCmd c = do
|
|
ret <- system c
|
|
return $ ret == ExitSuccess
|
|
|
|
testStart :: String -> IO ()
|
|
testStart s = do
|
|
putStr $ " checking " ++ s ++ "..."
|
|
hFlush stdout
|
|
|
|
testEnd :: Bool -> IO ()
|
|
testEnd r = putStrLn $ " " ++ show r
|
|
|
|
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 key t):ts) = do
|
|
testStart tname
|
|
val <- t
|
|
testEnd val
|
|
rest <- runTests ts
|
|
return $ (Config key val):rest
|
|
|
|
setup :: IO ()
|
|
setup = do
|
|
createDirectoryIfMissing True tmpDir
|
|
writeFile testFile "test file contents"
|
|
|
|
cleanup :: IO ()
|
|
cleanup = do
|
|
removeDirectoryRecursive tmpDir
|
|
|
|
main :: IO ()
|
|
main = do
|
|
setup
|
|
config <- runTests tests
|
|
writeSysConfig config
|
|
cleanup
|