{- 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 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 "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 = 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 = 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