155 lines
5.2 KiB
Haskell
155 lines
5.2 KiB
Haskell
{- Checks system configuration and generates SysConfig.hs. -}
|
|
|
|
module Build.Configure where
|
|
|
|
import System.Directory
|
|
import Control.Applicative
|
|
import System.Environment (getArgs)
|
|
import Control.Monad.IfElse
|
|
import Control.Monad
|
|
|
|
import Build.TestConfig
|
|
import Build.Version
|
|
import Utility.PartialPrelude
|
|
import Utility.Process
|
|
import Utility.SafeCommand
|
|
import Utility.ExternalSHA
|
|
import Utility.Env
|
|
import Utility.Exception
|
|
import qualified Git.Version
|
|
import Utility.DottedVersion
|
|
|
|
tests :: [TestCase]
|
|
tests =
|
|
[ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)
|
|
, TestCase "UPGRADE_LOCATION" getUpgradeLocation
|
|
, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
|
|
, TestCase "git version" getGitVersion
|
|
, testCp "cp_a" "-a"
|
|
, testCp "cp_p" "-p"
|
|
, testCp "cp_preserve_timestamps" "--preserve=timestamps"
|
|
, testCp "cp_reflink_auto" "--reflink=auto"
|
|
, TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null"
|
|
, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
|
|
, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
|
|
, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
|
|
, TestCase "wget supports -q --show-progress" checkWgetQuietProgress
|
|
, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
|
|
, TestCase "nice" $ testCmd "nice" "nice true >/dev/null"
|
|
, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
|
|
, TestCase "nocache" $ testCmd "nocache" "nocache true >/dev/null"
|
|
, TestCase "gpg" $ maybeSelectCmd "gpg"
|
|
[ ("gpg", "--version >/dev/null")
|
|
, ("gpg2", "--version >/dev/null") ]
|
|
, TestCase "lsof" $ findCmdPath "lsof" "lsof"
|
|
, TestCase "git-remote-gcrypt" $ findCmdPath "gcrypt" "git-remote-gcrypt"
|
|
, TestCase "ssh connection caching" getSshConnectionCaching
|
|
] ++ shaTestCases
|
|
[ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")
|
|
, (256, "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
|
|
, (512, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")
|
|
, (224, "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f")
|
|
, (384, "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b")
|
|
]
|
|
|
|
{- shaNsum are the program names used by coreutils. Some systems
|
|
- install these with 'g' prefixes.
|
|
-
|
|
- On some systems, shaN is used instead, but on other
|
|
- systems, it might be "hashalot", which does not produce
|
|
- usable checksums. Only accept programs that produce
|
|
- known-good hashes when run on files. -}
|
|
shaTestCases :: [(Int, String)] -> [TestCase]
|
|
shaTestCases l = map make l
|
|
where
|
|
make (n, knowngood) = TestCase key $
|
|
Config key . MaybeStringConfig <$> search (shacmds n)
|
|
where
|
|
key = "sha" ++ show n
|
|
search [] = return Nothing
|
|
search (c:cmds) = do
|
|
sha <- externalSHA c n "/dev/null"
|
|
if sha == Right knowngood
|
|
then return $ Just c
|
|
else search cmds
|
|
|
|
shacmds n = concatMap (\x -> [x, 'g':x]) $
|
|
map (\x -> "sha" ++ show n ++ x) ["sum", ""]
|
|
|
|
tmpDir :: String
|
|
tmpDir = "tmp"
|
|
|
|
testFile :: String
|
|
testFile = tmpDir ++ "/testfile"
|
|
|
|
testCp :: ConfigKey -> String -> TestCase
|
|
testCp k option = TestCase cmd $ testCmd k cmdline
|
|
where
|
|
cmd = "cp " ++ option
|
|
cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"
|
|
|
|
getUpgradeLocation :: Test
|
|
getUpgradeLocation = do
|
|
e <- getEnv "UPGRADE_LOCATION"
|
|
return $ Config "upgradelocation" $ MaybeStringConfig e
|
|
|
|
getGitVersion :: Test
|
|
getGitVersion = go =<< getEnv "FORCE_GIT_VERSION"
|
|
where
|
|
go (Just s) = return $ Config "gitversion" $ StringConfig s
|
|
go Nothing = do
|
|
v <- Git.Version.installed
|
|
let oldestallowed = Git.Version.normalize "1.7.1.0"
|
|
when (v < oldestallowed) $
|
|
error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)"
|
|
return $ Config "gitversion" $ StringConfig $ show v
|
|
|
|
checkWgetQuietProgress :: Test
|
|
checkWgetQuietProgress = Config "wgetquietprogress" . BoolConfig
|
|
. maybe False (>= normalize "1.16")
|
|
<$> getWgetVersion
|
|
|
|
getWgetVersion :: IO (Maybe DottedVersion)
|
|
getWgetVersion = catchDefaultIO Nothing $
|
|
extract <$> readProcess "wget" ["--version"]
|
|
where
|
|
extract s = case lines s of
|
|
[] -> Nothing
|
|
(l:_) -> normalize <$> headMaybe (drop 2 $ words l)
|
|
|
|
getSshConnectionCaching :: Test
|
|
getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
|
|
boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]
|
|
|
|
setup :: IO ()
|
|
setup = do
|
|
createDirectoryIfMissing True tmpDir
|
|
writeFile testFile "test file contents"
|
|
|
|
cleanup :: IO ()
|
|
cleanup = removeDirectoryRecursive tmpDir
|
|
|
|
run :: [TestCase] -> IO ()
|
|
run ts = do
|
|
args <- getArgs
|
|
setup
|
|
config <- runTests ts
|
|
if args == ["Android"]
|
|
then writeSysConfig $ androidConfig config
|
|
else writeSysConfig config
|
|
cleanup
|
|
whenM isReleaseBuild $
|
|
cabalSetup "git-annex.cabal"
|
|
|
|
{- Hard codes some settings to cross-compile for Android. -}
|
|
androidConfig :: [Config] -> [Config]
|
|
androidConfig c = overrides ++ filter (not . overridden) c
|
|
where
|
|
overrides =
|
|
[ Config "cp_reflink_auto" $ BoolConfig False
|
|
, Config "curl" $ BoolConfig False
|
|
, Config "sha224" $ MaybeStringConfig Nothing
|
|
, Config "sha384" $ MaybeStringConfig Nothing
|
|
]
|
|
overridden (Config k _) = k `elem` overridekeys
|
|
overridekeys = map (\(Config k _) -> k) overrides
|